Question

关注我的帖子MDN。

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

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

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

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

尝试使用不存在的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 2

你可以使用这样的函数：

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 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

复制行时存在if表的错误处理

3 个答案: