我很新的宏编程和目前正在创建一个分割表到新的工作表依赖于一个独特的变量,宏然后复制并粘贴每个工作表到一个单一的word文档拆分通过分页符。Excel宏根据单元格值给报告标题
我不能工作了怎么办,是创建一个宏,让每一页上的每个表基于一个单元格的值的标题。
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
请添加代码(编辑你的问题,按钮刚下标签),你必须在此刻,即使它不工作!对我们来说,使用某些东西会容易得多! – R3uK
谢谢您的及时答复,现在添加。这是底部需要工作的最后一个子功能。例如,我需要E2的值来在word文档中提供标题。这是一个黑客工作有点抱歉! – NatsWhiskas
我不是Word VBA的专家,但是当您在这里使用Excel和Word时,您需要指定在哪个应用程序中工作,特别是对于“选择”应该是“wdapp.Selection”或“ xlapp.Selection'(之前,在excel中使用'Set xlapp = Application'来定义xlapp) – R3uK