Excel Macro, чтобы предоставить заголовок отчета на основе значения ячейки

Question

Я очень новичок в программировании макросов и в настоящее время создаю макрос, который разбивает таблицу на новые рабочие листы, зависящие от уникальной переменной, а затем копирует и вставляет каждый лист в единый текстовый документ по разрыву страницы.

Что я не могу решить, как это сделать, это создать макрос, который дает каждой таблице на каждой странице заголовок, основанный на значении ячейки.

Option Explicit 

Sub Run_All() 
Call Organise_Table 
Call Rename_Column 
Call Isblank 
Call Split_Table 
Call SumColumn 
Call ExceltoWord 
Call Report_Title 
End Sub 

Sub Organise_Table() 
    Columns(1).EntireColumn.Delete 
    Columns(1).EntireColumn.Delete 
    Columns(2).EntireColumn.Delete 
    Columns(3).EntireColumn.Delete 
    Columns(3).EntireColumn.Delete 
End Sub 

Sub Rename_Column() 
    Range("A1") = "Contribution Type" 
    Range("B1") = "RefNo" 
    Range("C1") = "Title" 
    Range("D1") = "Initals" 
    Range("E1") = "Surname" 
    Range("F1") = "Balance Brought Forward" 
    Range("G1") = "Annual Interest Added" 
    Range("H1") = "Contributions Added" 
    Range("I1") = "Total Fund Value" 
End Sub 

Sub Isblank() 

    Application.ScreenUpdating = False 
    On Error Resume Next 
    With Range("F1:I14") 
     .SpecialCells(xlCellTypeBlanks).Formula = "0" 
     .Value = .Value 
    End With 
    Err.Clear 
    Application.ScreenUpdating = True 
End Sub 

Sub Split_Table() 

Dim lr As Long 
Dim Ws As Worksheet 
Dim vcol As Integer 
Dim i As Integer 
Dim iCol As Long 
Dim myarr As Variant 
Dim Title As String 
Dim titlerow As Integer 

vcol = 2 
Set Ws = Sheets("Sheet1") 
Title = "A1:I14" 


Application.ScreenUpdating = False 
lr = Ws.Cells(Ws.Rows.Count, vcol).End(xlUp).Row 
titlerow = Ws.Range(Title).Cells(1).Row 
iCol = Ws.Columns.Count 
Ws.Cells(1, iCol) = "Unique" 


For i = 2 To lr 
On Error Resume Next 
    If Ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(Ws.Cells(i, vcol), Ws.Columns(iCol), 0) = 0 Then 
    Ws.Cells(Ws.Rows.Count, iCol).End(xlUp).Offset(1) = Ws.Cells(i, vcol) 
    End If 
Next i 
myarr = Application.WorksheetFunction.Transpose(Ws.Columns(iCol).SpecialCells(xlCellTypeConstants)) 
Ws.Columns(iCol).Clear 
    For i = 2 To UBound(myarr) 
    Ws.Range(Title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
    Else 
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
    End If 
    Ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
    Sheets(myarr(i) & "").Columns.AutoFit 
    Next i 
Ws.AutoFilterMode = False 
Ws.Activate 
End Sub 

Sub SumColumn() 

Dim LastRow As Long 
Dim iRow As Long 
Dim iCol As Integer 
Dim nSheets As Integer 

For nSheets = 1 To 3 

With Worksheets(nSheets) 

LastRow = 0 

For iCol = 6 To 9 
iRow = .Cells(65536, iCol).End(xlUp).Row 
If iRow > LastRow Then LastRow = iRow 
Next iCol 

For iCol = 6 To 9 
.Cells(LastRow + 1, iCol) = Application.WorksheetFunction.Sum(Range(.Cells(1, iCol), .Cells(LastRow, iCol))) 
Next iCol 


iCol = 1 
.Cells(LastRow + 1, iCol).Value = ("Total") 

End With 

Next nSheets 

End Sub 


Sub ExceltoWord() 

Dim Ws As Worksheet 
Dim Wkbk1 As Workbook 
Dim strdocname As String 
Dim wdapp As Object 
Dim wddoc As Object 
Dim orng As Object 
Dim wdAutoFitwindow As String 



    Set Wkbk1 = ActiveWorkbook 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    strdocname = "\\VDC.COM\User\HomeDrives\GFSNRE\Desktop\Test19.Doc" 'Change this to whatever directory the report will be in 

    'file name & folder path 
    On Error Resume Next 
    'error number 429 
    Set wdapp = GetObject(, "Word.Application") 
    If Err.Number = 429 Then 
     Err.Clear 
     'create new instance of word application 
     Set wdapp = CreateObject("Word.Application") 
    End If 
    wdapp.Visible = True 
    'define paths to file 
    If Dir(strdocname) = "" Then 
     'MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Path\Name.doc", _ 
     '  vbExclamation, "The document does not exist " 
     'Exit Sub 
     Set wddoc = wdapp.Documents.Add 
    Else 
     Set wddoc = wdapp.Documents.Open(strdocname) 
    End If 
    For Each Ws In Wkbk1.Worksheets 
     Ws.Range("A1:I14").Copy 
     Set orng = wddoc.Range 
     orng.collapse 0 
     orng.Paste 
     orng.End = wddoc.Range.End 
     orng.collapse 0 
     orng.insertbreak Type:=7 
     Range("A1:I14").Borders.LineStyle = xlContinuous 
     wddoc.AutofitBehavior wdAutoFitwindow 
     Next Ws 

lbl_Exit: 
    Set orng = Nothing 
    Set wddoc = Nothing 
    Set wdapp = Nothing 
    Set Wkbk1 = Nothing 
    Set Ws = Nothing 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Exit Sub 

End Sub 

Sub Report_Title() 

    Dim Ws As Worksheet 
    Dim MyText As String 
    Dim MyRange As Object 

    Set MyRange = ActiveWorkbook.Range 

    MyText = Ws.Range("E3").Value 
    ' Selection Example: 
    Selection.InsertBefore (MyText) 
    ' Range Example: Inserts text at the beginning 
    ' of the active document. 
    MyRange.InsertBefore (MyText) 

End Sub 

Answer 1

Существует одна ошибка здесь:

Dim Ws As Worksheet 
Dim MyText As String 
Dim MyRange As Object 

Set MyRange = ActiveWorkbook.Range 

MyText = Ws.Range("E3").Value '<==== WS is not properly defined yet 

Вы используете Ws. сказать, на каком рабочем листе вы работаете, что хорошо. Но, поскольку это переменная уровня процедуры, она не указывает ни на что полезную. Вы, наверное, нужно что-то вроде:

Set MyRange = ActiveWorkbook.Range 
Set Ws = ActiveWorkbook.Sheets("Sheet1") 'assuming you want to read "E3" on the sheet "Sheet1" of the active workbook, that's the line to add 
MyText = Ws.Range("E3").Value '<==== WS is now properly defined 

Если вы зайдете в режим отладки, вы не должны иметь ничего «MYTEXT» в вашей версии, и что-то в шахте. Содержание E3 в листе Sheet1.

Answer 2

Две вещи:

1. Вы не должны отключить обработку для всего кода ошибки. Если ничего не работает, VBA не может сказать вам, почему или где проблема есть. Хотя это стандартная практика использования On Error Resume Next, когда с использованием GetObject/CreateObject, также стандартная практика превращать обработку ошибок ПОСЛЕ ИМЯ ... End If. Вам нужно добавить строку : Ошибка Error GoTo 0, где у вас нет кода обработчика ошибок.
   2. На основе вашего образца кода напишите в заголовке перед тем, как вставлять таблицу.

Так что-то вроде этого:

For Each Ws In Wkbk1.Worksheets 
    Ws.Range("A1:I14").Copy 
    Set orng = wddoc.Range 
    orng.collapse 0 
    orng.Text = Ws.Range([cell reference with title]) & vbCr 
    orng.collapse 0 
    orng.Paste 
    orng.End = wddoc.Range.End 
    orng.collapse 0 
    orng.insertbreak Type:=7 
    Range("A1:I14").Borders.LineStyle = xlContinuous 
    wddoc.AutofitBehavior wdAutoFitwindow 
Next Ws