Question

我对宏编程非常陌生，目前正在创建一个宏，将表拆分为依赖于唯一变量的新工作表，然后将每个工作表复制并粘贴到按分页符拆分的单个word文档中。

我无法弄清楚如何做，是创建一个宏，根据单元格的值为每个页面上的每个表提供一个标题。

 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”中什么也没有，我的内容也是。 Sheet Sheet1中E3的内容。

Answer 2

两件事：

您不应该关闭整个代码的错误处理。如果事情没有工作VBA无法告诉你问题的原因或地点是。虽然它的标准做法是使用On Error Resume Next 使用GetObject / CreateObject，它也是转向的标准做法在If ... End If之后重新开启错误处理。你需要添加 line：On Error GoTo 0，其中没有错误处理程序代码。
1. 根据您的示例代码，在粘贴表格之前写入标题。

这样的事情：

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

Excel宏根据单元格值提供报表标题

2 个答案: