2015-12-07 50 views
0

我很新的宏编程和目前正在创建一个分割表到新的工作表依赖于一个独特的变量,宏然后复制并粘贴每个工作表到一个单一的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 
+0

请添加代码(编辑你的问题,按钮刚下标签),你必须在此刻,即使它不工作!对我们来说,使用某些东西会容易得多! – R3uK

+0

谢谢您的及时答复,现在添加。这是底部需要工作的最后一个子功能。例如,我需要E2的值来在word文档中提供标题。这是一个黑客工作有点抱歉! – NatsWhiskas

+1

我不是Word VBA的专家,但是当您在这里使用Excel和Word时,您需要指定在哪个应用程序中工作,特别是对于“选择”应该是“wdapp.Selection”或“ xlapp.Selection'(之前,在excel中使用'Set xlapp = Application'来定义xlapp) – R3uK

回答

0

有一个错误的位置:

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”,以及东西我的。片材Sheet1中的E3的内容。

0

两件事情:

  1. 你不应该关闭错误处理的全部代码。如果 事情不起作用VBA不能告诉你为什么或在哪里问题 是。虽然这是STANDAR的做法是使用上的错误继续下一步时 在将GetObject /的CreateObject它也是标准的做法,把 错误处理回后的如果...如果结束。您需要添加 行:On 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 
相关问题