如何使我的VBA代码什么都不做，并移动到下一步/ VBA运行时错误91

Question

我有一个问题与我的代码的结果:主要思想是，我有一个字模板，我复制粘贴不同的表从excel文件。这些表位于12个不同的表中，分别命名为表1、表2等。当这些表中有一些数据时，代码可以完美地工作。这是完整的代码:

Sub CreateBasicWordReport()
'Create word doc automatically
Dim wApp As Word.Application
Dim SaveName As String
Set wApp = New Word.Application
With wApp
'Make word visible
.Visible = True
.Activate
.Documents.Add "C:UsersMyDesktopTemplateWordFile.dotx"
'paste supplier name in word
Sheets("Sheet1").Range("C1").Copy
.Selection.Goto what:=wdGoToBookmark, name:="SupplierName"
.Selection.PasteSpecial DataType:=wdPasteText
'Dynamic range
Dim Table1 As Worksheet
Dim Table2 As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set Table1 = Worksheets("Table 1")
Set Table2 = Worksheets("Table 2")
Set StartCell = Range("A1")
'Paste table 1 in word
Worksheets("Table 1").UsedRange
LastRow = Table1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Table1.Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table1"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
'Paste table 2 in word
Worksheets("Table 2").UsedRange
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Table 2").Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table2"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
'Save doc to a specific location and with a specific title
Dim name As String
name = "C:UsersMyDesktopSupplier" & "DocName" & "_" & _
Sheets("Sheet1").Range("C1").Value & "_" & Sheets("Sheet1").Range("H1").Value & _
"_" & Format(Now, "yyyy-mm-dd") & ".docx"
.ActiveDocument.SaveAs2 Filename:=name
End With
End Sub

问题是当表格是空白的时候。我可能只需要一个表(从表1)，如果下一页(表2)是空的，那么我希望VBA什么都不做，并移动到下一步。但是我在这行代码中得到运行时错误91:

 LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

我已经尝试了"on error resume next"命令，像这样:

'Paste table 2 in word
Worksheets("Table 2").UsedRange
On Error Resume Next
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Table 2").Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table2"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True   

但是在这种情况下，它确实给我的word文件带来了一个空表(5行，10行，没有任何内容，只是一个表的轮廓)，而我只是希望它是空白的/什么都没有出现在我的word文件上。

有谁知道如何解决这个问题吗?

Answer 1

您可能只是将If Not IsEmpty(Table1.UsedRange) Then语句添加到您的代码中。这将防止在工作表完全为空时运行代码。如果你需要更多的帮助，请评论。

Sub CreateBasicWordReport()
'Create word doc automatically
Dim wApp As Word.Application
Dim SaveName As String
Set wApp = New Word.Application
With wApp
'Make word visible
.Visible = True
.Activate
.Documents.Add "C:UsersMyDesktopTemplateWordFile.dotx"
'paste supplier name in word
Sheets("Sheet1").Range("C1").Copy
.Selection.Goto what:=wdGoToBookmark, name:="SupplierName"
.Selection.PasteSpecial DataType:=wdPasteText
'Dynamic range
Dim Table1 As Worksheet
Dim Table2 As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set Table1 = Worksheets("Table 1")
Set Table2 = Worksheets("Table 2")
Set StartCell = Range("A1")
'Paste table 1 in word
If Not IsEmpty(Table1.UsedRange) Then
  LastRow = Table1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Table1.Range("A1:J" & LastRow).Copy
  .Selection.GoTo what:=wdGoToBookmark, name:="Table1"
  .Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
  Placement:=wdAlignRowLeft, DisplayAsIcon:=True
End If
'Paste table 2 in word
If Not IsEmpty(Table2.UsedRange) Then
  LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Table2.Range("A1:J" & LastRow).Copy
  .Selection.GoTo what:=wdGoToBookmark, name:="Table2"
  .Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
  Placement:=wdAlignRowLeft, DisplayAsIcon:=True
End If
'Save doc to a specific location and with a specific title
Dim name As String
name = "C:UsersMyDesktopSupplier" & "DocName" & "_" & _
Sheets("Sheet1").Range("C1").Value & "_" & Sheets("Sheet1").Range("H1").Value & _
"_" & Format(Now, "yyyy-mm-dd") & ".docx"
.ActiveDocument.SaveAs2 Filename:=name
End With
End Sub

Answer 2

不幸的是我不能评论Fabian的回答，但是他的建议可能会解决你的问题。我只是认为你应该知道你的代码在做什么上的"on Error Resume Next"是去下一行，无论是否有错误。因此，为了在出现错误的情况下告诉程序做一些不同的事情，您必须验证错误是否发生并处理它。

Answer 3

您可以通过将表复制/粘贴到特定的子表来避免一些代码重复并扩展您的代码应用程序:

Sub PasteTables(docContent As Word.Range, numTables As Long)
    Dim iTable As Long
    Dim myRng As Range
    With docContent
        For iTable = 1 To numTables
            Set myRng = Worksheets("Table " & iTable).UsedRange
            If Not IsEmpty(myRng) Then
                myRng.Copy
                .Goto(what:=wdGoToBookmark, name:="Table" & iTable).PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
                Placement:=wdAlignRowLeft, DisplayAsIcon:=True
                Application.CutCopyMode = False
            End If
        Next iTable
    End With
End Sub

相应地，你的主代码将缩短为:

Option Explicit
Sub CreateBasicWordReport()
    'Create word doc automatically
    Dim wApp As Word.Application
    Dim name As String
    Set wApp = New Word.Application
    sheets("Sheet01").Range("C1").Copy
    With wApp.Documents.Add("C:UsersMyDesktopTemplateWordFile.dotx") '<-- open word document and reference it        
        'Make word visible
        .Parent.Visible = True
        .Parent.Activate
        'paste supplier name in word
        .content.Goto(what:=wdGoToBookmark, name:="SupplierName").PasteSpecial DataType:=wdPasteText
        Application.CutCopyMode = False '<-- it's always a good habit to set it after pasting has taken place
        'paste tables
        PasteTables .content, 2 '<-- call your specific Sub passing the referenced document content and "2" as the maximum number of tables to loop through
        'Save doc to a specific location and with a specific title
        name = "C:UsersMyDesktopSupplier" & "DocName" & "_" & _
        sheets("Sheet1").Range("C1").Value & "_" & sheets("Sheet1").Range("H1").Value & _
        "_" & Format(Now, "yyyy-mm-dd") & ".docx"
        .ActiveDocument.SaveAs2 Filename:=name
    End With
End Sub