复制行时是否存在工作表的错误处理

Question

关注我的帖子If cell value matches a UserForm ComboBox column, then copy to sheet。

我已经设法让代码工作以移动检查名称，然后移动到正确的工作表。

我遇到的问题是检查工作表是否存在。如果它在工作表和组合框中的第 2 列中找到匹配项，但没有该值的工作表，则它会使代码崩溃。

1. 将所有信息复制到相关工作表后，我希望它显示一个消息框，告诉用户已将多少行数据复制到相应工作表。

   Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
   
   With Application
   .ScreenUpdating = False
   .EnableEvents = False
   .CutCopyMode = False
   End With
   
   On Error GoTo bm_Close_Out
   
   ' find last row
   lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
   
   For i = 3 To lastG
       lookupVal = sheets("Global").Cells(i, "Q") ' value to find
       ' loop over values in "details"
       For j = 0 To Me.ComboBox2.ListCount - 1
           currVal = Me.ComboBox2.List(j, 2) ' value to match
           If lookupVal = currVal Then
               Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
               strWS = Me.ComboBox2.List(j, 1)
               On Error GoTo bm_Need_Worksheet  '<~~ if the worksheet in the next line does not exist, go make one
               With Worksheets(strWS)
                   rngCPY.Copy
                   .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
               End With
           End If
       Next j
   Next i
   
   GoTo bm_Close_Out
   
   bm_Need_Worksheet:
   On Error GoTo 0
   With Worksheet
   Dim wb As Workbook: Set wb = ThisWorkbook
   Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
   Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
   Dim wsNew As Worksheet
   Dim lastRow2 As Long
   Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
   Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
   Dim Name As String: Name = Left(Contract, SpacePos)
   Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
   
   Dim NewName As String: NewName = strWS
   Dim CCName As Variant: CCName = Me.ComboBox2.List(j, 0)
   
   Dim lastRow As Long: lastRow = wsPayment.Range("U36:U53").End(xlDown).row
   
   If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
   lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
   Else
   lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
   End If
   
   wsTemplate.Visible = True
   wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
   wsTemplate.Visible = False
   
   If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
   With wsPayment
       For Each cell In .Range("A23:A39")
           If Len(cell) = 0 Then
               If sheets("Payment Form").Range("A20").value = "Network" Then
                   cell.value = NewName & " - " & Name2 & ": " & CCName
               Else
                   cell.value = NewName & " - " & Name2 & ": " & CCName
               End If
               Exit For
           End If
       Next cell
   End With
   Else
   With wsPayment
       For Each cell In .Range("A18:A34")
           If Len(cell) = 0 Then
               If sheets("Payment Form").Range("A20").value = "Network" Then
                   cell.value = NewName & " - " & Name2 & ": " & CCName
               Else
                   cell.value = NewName & " - " & Name2 & ": " & CCName
               End If
               Exit For
           End If
       Next cell
   End With
   End If
   
   If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
   With wsNew
       .Name = NewName
       .Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
       .Range("D6").value = wsPayment.Range("L11").value
       .Range("D8").value = wsPayment.Range("C9").value
       .Range("D10").value = wsPayment.Range("C11").value
   End With
   Else
   With wsNew
       .Name = NewName
       .Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
       .Range("D6").value = wsPayment.Range("L11").value
       .Range("D8").value = wsPayment.Range("C9").value
       .Range("D10").value = wsPayment.Range("C11").value
   End With
   End If
   
   wsPayment.Activate
   
   With wsPayment
       .Range("J" & lastRow2 + 1).value = 0
       .Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
       .Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
       .Range("U" & lastRow + 1).value = NewName & ": "
       .Range("V" & lastRow + 1).Formula = "='" & NewName & "'!I21"
       .Range("W" & lastRow + 1).Formula = "='" & NewName & "'!I23"
       .Range("X" & lastRow + 1).Formula = "='" & NewName & "'!K21"
   End With
   End With
   
   On Error GoTo bm_Close_Out
   Resume
   
   bm_Close_Out:
   
   With Application
   .ScreenUpdating = True
   .EnableEvents = True
   .CutCopyMode = True
   End With
   

在 Jeeped 的帮助下，我设法获得了将行复制到相关工作表的代码，如果工作表不存在，则创建它。我只需要解决上述问题二的帮助。

Answer 1

你可以使用这样的函数：

Sub test_atame()
Dim Ws As Worksheet

Set Ws = Sheet_Exists(ThisWorkbook, "Sheet1")
Set Ws = Sheet_Exists(ActiveWorkbook, "Sheet1")

End Sub

这里是函数：

Public Function Sheet_Exists(aWorkBook As Workbook, Sheet_Name As String) As Worksheet
Dim Ws As Worksheet, _
    SExistS As Boolean

SExistS = False
For Each Ws In aWorkBook.Sheets
    If Ws.Name <> Sheet_Name Then
    Else
        SExistS = True
        Exit For
    End If
Next Ws

If SExistS Then
    Set Sheet_Exists = aWorkBook.Sheets(Sheet_Name)
Else
    Set Sheet_Exists = Nothing
    MsgBox "The sheet " & Sheet_Name & " wasn't found in " & aWorkBook.Name & vbCrLf & _
            "Break code to check and correct.", vbCritical + vbOKOnly
End If
End Function

Answer 2

尝试使用不存在的Worksheet Object 会引发错误。如果您发现该错误并使用您正在查找的名称创建一个工作表，您可以Resume 回到引发错误的位置并继续您的处理。

Private Sub CommandButton7_Click()
    Dim i As Long, j As Long, lastG As Long, strWS As String, strMSG As String
    dim rngHDR as range, rngCPY aS range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With

    On Error GoTo bm_Close_Out

    ' find last row
    lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To lastG
        lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
        ' loop over values in "details"
        For j = 0 To Me.ComboBox2.ListCount - 1
            currVal = Me.ComboBox2.List(j, 2) ' value to match
            If lookupVal = currVal Then
                set rngHDR = Sheets("Global").Cells(1, "Q").EntireRow
                set rngCPY = Sheets("Global").Cells(i, "Q").EntireRow
                strWS = Me.ComboBox2.List(j, 1)
                On Error GoTo bm_Need_Worksheet  '<~~ if the worksheet in the next line does not exist, go make one
                With WorkSheets(strWS)
                     rngCPY .copy
                    .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
                End With
                exit for
            End If
        Next j
        if j >= Me.ComboBox2.ListCount then _
            strMSG = strMSG & "Not found: " & lookupVal & chr(10)
    Next i

GoTo bm_Close_Out      

bm_Need_Worksheet:
    On Error GoTo 0
    With Worksheets.Add(after:=Sheets(Sheets.Count))
        .Name = strWS
        'maybe make a header row here; watch out you do not lose your copy
        rngHDR.copy destination:=.cells(1, 1)
    End With
    On Error GoTo bm_Close_Out
    Resume

bm_Close_Out:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .CutCopyMode = False
    End With
    debug.print strMSG 
    'the next is NOT recommended as strMSG could possibly be VERY long
    'if cbool(len(strMSG)) then msgbox strMSG 
End Sub

有一个关于新工作表是否需要列标题标签行的问题，但这应该很容易纠正。

Answer 3

可能是这样的检查：

Public Function SheetExists(ByVal Book As Workbook, ByVal SheetName As String) As Boolean

On Error Resume Next
Dim wsTest As Worksheet
Set wsTest = Book.Worksheets(SheetName)
If Not wsTest Is Nothing Then SheetExists = True

End Function