我正试图想出一种运行一段代码的不同方法。
基本上我的代码目前正在做的是,循环遍历全局工作表中的列Q,然后循环通过Combobox2,当它找到匹配时,整个行被移动到组合框的第1列中的工作表引用。 / p>
是否可以使用Match功能来实现相同的结果并加快代码的速度?
这是我正在使用的代码,它完成了我需要它做的事情,但我无法让错误处理工作。它有很多行数据可以循环使用它可能需要很长时间!
选项1:
Private Sub CommandButton6_Click()
Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
StartTime = Timer
If Range("L9") = "" Then
MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation"
Exit Sub
End If
If sheets("Global").Range("A3") = "" Then
MsgBox "The appears to be no application loaded." & vbLf & vbLf & "Please load" & " " & Range("C11") & " " & "App and Planet Info, then click button 2 and try again.", vbExclamation, "Invalid Operation"
Exit Sub
End If
On Error GoTo bm_Close_Out
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
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 i
Next j
End If
Else
If sheets("PAYMENT FORM").Range("L35") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
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 i
Next j
End If
End If
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, 2)
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("C9").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("C9").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:
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
选项2:
Private Sub CommandButton1_Click()
Dim j As Long, strWS As String, rngCPY As Range, FirstAddress As String, sSheetsWithData As String
Dim sSheetsWithoutData As String, lSheetRowsCopied As Long, lAllRowsCopied As Long, bFound As Boolean, sOutput As String
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.EnableEvents = False
End With
StartTime = Timer
On Error GoTo bm_Close_Out
For j = 0 To UserForm2.ComboBox2.ListCount - 1
bFound = False
currval = UserForm2.ComboBox2.List(j, 0) ' value to match
With sheets("Global")
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
If Not rngCPY Is Nothing Then
bFound = True
lSheetRowsCopied = 0
FirstAddress = rngCPY.Address
Do
lSheetRowsCopied = lSheetRowsCopied + 1
strWS = UserForm2.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet
With Worksheets(strWS)
rngCPY.EntireRow.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop Until rngCPY Is Nothing Or rngCPY.Address = FirstAddress
Else
bFound = False
End If
If bFound Then
sSheetsWithData = sSheetsWithData & " " & strWS & " (" & lSheetRowsCopied & ")" & vbLf
lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
End If
End With
Next j
bm_Need_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 = UserForm2.ComboBox2.List(j, 2)
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("C9").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("C9").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
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
If sSheetsWithData <> vbNullString Then
sOutput = "# of rows copied to sheets:" & vbLf & vbLf & sSheetsWithData & vbLf & _
"Total rows copied = " & lAllRowsCopied & vbLf & vbLf
Else
sOutput = "No sheets contained data to be copied" & vbLf & vbLf
End If
If sSheetsWithoutData <> vbNullString Then
sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
Else
sOutput = sOutput & "All sheets had data that was copied."
End If
If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
Set rngCPY = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.EnableEvents = True
End With
End Sub
答案 0 :(得分:1)
好的......这更像是尝试而不是答案。请检查它是否有效以及是否更快。
仅将此宏用于工作簿的副本!
Private Sub CommandButton2_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
Dim noFind As Variant: noFind = UserForm2.ComboBox2.List '<~~~ get missed items
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = Sheets("Global").Cells(Rows.Count, 17).End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If Sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
'~~~ acivate next line to sort (will speed up a lot)
'Sheets("Global").Range("A3:R" & Cells(Rows.Count, 17).End(xlUp).row).Sort cells(3,17), 1
For j = 0 To UserForm2.ComboBox2.ListCount - 1
noFind(j, 4) = 0
For i = 3 To lastG
If noFind(j, 0) = Sheets("Global").Cells(i, 17) Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With Sheets("Payment Form").Range("C9"): nStr = Right(.Value, Len(.Value) - Len(Left(.Value, InStr(.Value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = Sheets("Payment Form").Range("U36:U53").End(xlDown).row + 1
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = Sheets("Payment Form").Range(strRng).End(xlDown).row + 1
Dim wsNew As Worksheet: .Sheets("Template").Copy .Sheets(.Sheets.Count): Set wsNew = .Sheets(.Sheets.Count): wsNew.Move .Sheets("Details")
With Sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If Sheets("Payment Form").Range("C9").Value = "Network" Then
cell.Offset.Value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.Value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
.Visible = -1
.Name = strWS
.Cells(4, 4).Value = Sheets("Payment Form").Range(strRng).End(xlDown).Value
.Cells(6, 4).Value = Sheets("Payment Form").Cells(12, 12).Value
.Cells(8, 4).Value = Sheets("Payment Form").Cells(9, 3).Value
.Cells(10, 4).Value = Sheets("Payment Form").Cells(11, 3).Value
End With
With .Sheets("Payment Form")
.Activate
.Cells(lastRow2, 10).Value = 0
.Cells(lastRow2, 12).Formula = "=N" & lastRow2 & "-J" & lastRow2 & ""
.Cells(lastRow2, 14).Formula = "='" & strWS & "'!L20"
.Cells(lastRow, 21).Value = strWS & ": "
.Cells(lastRow, 22).Formula = "='" & strWS & "'!I21"
.Cells(lastRow, 23).Formula = "='" & strWS & "'!I23"
.Cells(lastRow, 24).Formula = "='" & strWS & "'!K21"
End With
End With
End If
On Error GoTo 0
While Sheets("Global").Cells(k + 1, 17).Value = noFind(j, 0) And k < lastG
k = k + 1
Wend
Set rngCPY = Sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
noFind(j, 4) = noFind(j, 4) + k - i + 1
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
'noFind(x, y) > x = item / y: 0 = name / y: 4 = counter
noFind(0, 0) = noFind(0, 0) & " " & noFind(0, 4) & " times copied"
For i = 1 To UBound(noFind)
noFind(0, 0) = noFind(0, 0) & vbLf & noFind(i, 0) & " " & noFind(i, 4) & " times copied"
Next
MsgBox noFind(0, 0)
End Sub
首先:您可以添加一些空行以便更好地理解......
大多数部分只是缩短了视图(它们仍然相同)。
使用排序选项时,它会在一个步骤中复制/粘贴每个关键字的所有行。这不仅听起来更快......但是,你可以再次使用
请检查它是否适用于您的真实工作簿(它的副本,但内部包含所有数据)。我还没有完成任何&#34;非常速度调整&#34;。
答案 1 :(得分:0)
你可以尝试这样的事情。 Range.Find-Method基本上查看给定范围,您可以指定一个值。如果找到匹配项,则可以存储找到匹配项的单元格。
如果需要,您还可以使用.FindNext
查找该值的下一个匹配项。
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
Do While Not rngCPY Is Nothing
strWs = Me.ComboBox2.List(j, 1)
rngCPY.EntireRow.Copy
With Worksheets(strWS)
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop
Next j
答案 2 :(得分:0)
以下是代码的一小部分,用于替换全局中每个单元格的循环!Q3:Q *&lt; last_row&gt; *以及MATCH function的VBA版本。
Dim rw As Long, rngGQs As Range '<~~ put this closer to the top with the other variable declarations
' find last row
'lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row '<~~old way
With Sheets("Global") '<~~new way
Set rngGQs = .Range(Cells(3, "Q"), .Cells(Rows.Count, "Q").End(xlUp)) '< ~~ all of the cells to look at
End With
If InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If Sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
'For i = 3 To lastG '<~~old way
'lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
'If lookupVal = currval Then
If Not IsError(Application.Match(currval, rngGQs, 0)) Then '<~~new way
rw = Application.Match(currval, rngGQs, 0)
Set rngCPY = Sheets("Global").Cells(rw, "Q").EntireRow
'all the rest here
当您获得满意的工作订单时,它将成为Code Review (Excel)建议的主要候选人。