复制行时，如果存在纸张，则处理错误 [英] Error handling for if sheets exists when copying rows
问题描述
跟随我的帖子如果单元格值与UserForm ComboBox列匹配，则复制到工作表。
我已经设法使代码移动检查名称，然后移动到正确的表格。
I have managed to get the code to work to move the check the names and move then to the correct sheets.
我遇到的问题是检查表是否存在。如果它在组合框中的工作表和列2中找到匹配项，但是没有值的表单，那么它会崩溃代码。
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.
-
将所有信息复制到相关表格后，我希望显示一个msgbox，告诉用户有多少行数据被复制到相应的表格。
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
在Jeeped的帮助下，我已经设法获取将行复制到相关工作表的代码，如果工作表不不存在，然后它创建它。
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.
推荐答案
尝试使用不存在的工作表对象会引发错误。如果您遇到该错误并使用您要查找的名称创建工作表，则可以将 Resume 恢复到抛出错误的位置并继续处理。 p>
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.
这篇关于复制行时，如果存在纸张，则处理错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
