Error handling for if sheets exists when copying rows

问题

following my post If cell value matches a UserForm ComboBox column, then copy to sheet.

I have managed to get the code to work to move the check the names and move then to the correct sheets.

The problem i am having is checking if the sheets exists. If it finds a match in the sheet and column 2 in the combobox but there is no sheet for the value then it crashes the code.

2. Once all the information has been copied to the relevant sheets, i would like it to display a msgbox telling the user how many rows of data have been copied to the respective sheets.

   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
   

With help from Jeeped I have manage to get the code for copying the rows to the relevant sheets, and if the sheet doesn't exists then it create it. I just need help with problem two above.

回答1:

Attempting to use a Worksheet Object that does not exist throws an error. If you catch that error and create a worksheet with the name that you are looking for, you can Resume back to the point where the error was thrown and continue your processing.

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

There is a question about whether the new worksheet needs a column header label row but that should be fairly easily rectified.

回答2:

You could use a function like this :

Sub test_atame()
Dim Ws As Worksheet

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

End Sub

Here is the function :

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

回答3:

Maybe a check like:

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

来源：https://stackoverflow.com/questions/33733182/error-handling-for-if-sheets-exists-when-copying-rows