跟随我的帖子。如果单元格值与UserForm ComboBox列匹配,则复制到工作表。
我已经设法让代码工作起来,检查名称,然后移动到正确的表格。
我遇到的问题是检查床单是否存在。如果它在工作表和组合框中的第2列中找到匹配项,但没有该值的工作表,则会崩溃代码。
-
一旦所有信息都被复制到相关的工作表中,我希望它显示一个消息框,告诉用户有多少行数据被复制到了相应的工作表。
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的帮助下,我设法获得了将行复制到相关工作表的代码,如果工作表不存在,它就会创建它。我只需要解决上面的第二个问题。
尝试使用不存在的工作表对象会引发错误。如果您发现该错误并使用您正在查找的名称创建工作表,则可以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
有一个问题是,新工作表是否需要列标题标签行,但这应该很容易纠正。
您可以使用这样的函数:
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
也许是像这样的检查
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