我有大约2500行代码。我意识到我需要将我的代码分解为过程,但是不确定如何这样做。有没有办法让第一个过程的消息框从第二个过程运行?我收到的错误消息是“过程太长”
Sub Matt_Liam()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim ws3 As Worksheet
Set ws3 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim ws4 As Worksheet
Set ws4 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim ws5 As Worksheet
Set ws5 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim ws6 As Worksheet
Set ws6 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim rwqty2 As Long, lastrowqty2 As Long, MySelqty2 As Range 'Grabs skus and moves to new sheet
With Worksheets("orders (3)")
For rwqty2 = 1000 To 2 Step -1
If .Cells(rwqty2, 25).Value Like "*2*" Then
If MySelqty2 Is Nothing Then
Set MySelqty2 = .Cells(rwqty2, 1).EntireRow
Else
Set MySelqty2 = Union(MySelqty2, .Cells(rwqty2, 1).EntireRow)
End If
End If
Next rwqty2
End With
With ThisWorkbook.Worksheets("orders (3)")
lastrowqty2 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySelqty2 Is Nothing Then
MySelqty2.Copy Destination:=.Cells(lastrowqty2 + 1, 1)
'MySelqty3.Delete
End If
End With
Dim rwqty3 As Long, lastrowqty3 As Long, MySelqty3 As Range 'Grabs skus and moves to new sheet
With Worksheets("orders (3)")
For rwqty3 = 1000 To 2 Step -1
If .Cells(rwqty3, 25).Value Like "*3*" Then
If MySelqty3 Is Nothing Then
Set MySelqty3 = .Cells(rwqty3, 1).EntireRow
Else
Set MySelqty3 = Union(MySelqty3, .Cells(rwqty3, 1).EntireRow)
End If
End If
Next rwqty3
End With
With ThisWorkbook.Worksheets("orders (3)")
lastrowqty3 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySelqty3 Is Nothing Then
MySelqty3.Copy Destination:=.Cells(lastrowqty3 + 1, 1)
'MySelqty3.Delete
End If
End With
With ThisWorkbook.Worksheets("orders (3)")
lastrowqty3 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySelqty3 Is Nothing Then
MySelqty3.Copy Destination:=.Cells(lastrowqty3 + 1, 1)
'MySelqty3.Delete
End If
End With
Worksheets("orders (3)").Range("X1:AO300").Cut Worksheets("orders (3)").Range("Z1:AQ300") 'Makes room for texttocolumns
Dim objRange1 As Range
With Workbooks("orders (3).xlsx").Worksheets("orders (3)")
Set objRange1 = .Range("W1:W300")
objRange1.TextToColumns _
Destination:=.Range("W1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:="|"
End With
Worksheets("orders (3)").Range("A1:AY300").Copy Worksheets("Sheet1").Range("A1:AY300") 'moves to sheet1
Workbooks("orders (3)").Worksheets("Sheet1").Range("A:U").Clear 'clears uneeded columns in Sheet1 workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("AB:AC").Clear
Workbooks("orders (3)").Worksheets("Sheet1").Range("AE:AE").Clear
Workbooks("orders (3)").Worksheets("Sheet1").Range("AG:AY").Clear
Workbooks("orders (3)").Worksheets("Sheet1").Range("Z:Z").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("A:A") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("X:X").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("B:B") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("Y:Y").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("D:D") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("AD:AD").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("F:F") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("V:V").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("I:I") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("W:W").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("J:J") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("AF:AF").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("L:L") 'cleans up prodcution workbook
Dim rw11 As Long
With Worksheets("Sheet1")
For rw11 = 1000 To 2 Step -1
If .Cells(rw11, 6).Value Like "*Last Name:*" Then
Dim objRange11 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange11 = .Range("F1:F300")
objRange11.TextToColumns _
Destination:=.Range("F1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:="|"
End With
End If
Next rw11
End With
Dim rw12 As Long
For rw12 = 1000 To 1 Step -1
With Worksheets("Sheet1")
If .Cells(rw12, 6).Value Like "*Player Number*" Then
.Cells(rw12, 6).Cut Destination:=.Cells(Rows.Count, 7).End(xlUp)(2)
.Cells(rw12, 6).Delete (xlUp)
End If
End With
Next
Worksheets("Sheet1").Range("G1:L300").Cut Worksheets("Sheet1").Range("H1:M300")
Dim objRange2 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange2 = .Range("B1:B300")
objRange2.TextToColumns _
Destination:=.Range("B1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
End With
Dim objRange3 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange3 = .Range("D1:D300")
objRange3.TextToColumns _
Destination:=.Range("D1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
End With
Dim objRange4 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange4 = .Range("F1:F300")
objRange4.TextToColumns _
Destination:=.Range("F1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
End With
Dim objRange5 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange5 = .Range("H1:H300")
objRange5.TextToColumns _
Destination:=.Range("H1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
End With
Dim objRange6 As Range
With Workbooks("orders (3)").Worksheets("Sheet1")
Set objRange6 = .Range("K1:K300")
objRange6.TextToColumns _
Destination:=.Range("K1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
End With
Worksheets("Sheet1").Range("B:B").Clear
Worksheets("Sheet1").Range("D:D").Clear
Worksheets("Sheet1").Range("F:F").Clear
Worksheets("Sheet1").Range("H:H").Clear
Worksheets("Sheet1").Range("K:K").Clear
Workbooks("orders (3)").Worksheets("Sheet1").Range("C:C").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("B:B") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("E:E").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("C:C") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("G:G").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("D:D") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("I:I").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("E:E") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("J:J").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("F:F") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("L:L").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("G:G") 'cleans up prodcution workbook
Workbooks("orders (3)").Worksheets("Sheet1").Range("M:M").Cut _
Workbooks("orders (3)").Worksheets("Sheet1").Range("H:H") 'cleans up prodcution workbook
Dim rw As Long, lastrow As Long, MySel As Range 'Grabs skus and moves to new sheet
With Worksheets("Sheet1")
For rw = 1000 To 2 Step -1
If .Cells(rw, 1).Value Like "*11-*" Then
If MySel Is Nothing Then
Set MySel = .Cells(rw, 1).EntireRow
Else
Set MySel = Union(MySel, .Cells(rw, 1).EntireRow)
End If
End If
Next rw
End With
With ThisWorkbook.Worksheets("Sheet2")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel Is Nothing Then
MySel.Copy Destination:=.Cells(lastrow + 1, 1)
'MySel.Delete
End If
End With
Dim rw1 As Long, lastrow1 As Long, MySel1 As Range 'Grabs skus and moves to new sheet
With Worksheets("Sheet1")
For rw1 = 1000 To 2 Step -1
If .Cells(rw1, 1).Value Like "*22-*" Then
If MySel1 Is Nothing Then
Set MySel1 = .Cells(rw1, 1).EntireRow
Else
Set MySel1 = Union(MySel1, .Cells(rw1, 1).EntireRow)
End If
End If
Next rw1
End With
With ThisWorkbook.Worksheets("Sheet3")
lastrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel1 Is Nothing Then
MySel1.Copy Destination:=.Cells(lastrow1 + 1, 1)
'MySel1.Delete
End If
End With
Dim rw2 As Long, lastrow2 As Long, MySel2 As Range 'Grabs skus and moves to new sheet
With Worksheets("Sheet1")
For rw2 = 1000 To 2 Step -1
If .Cells(rw2, 1).Value Like "*33-*" Then
If MySel2 Is Nothing Then
Set MySel2 = .Cells(rw2, 1).EntireRow
Else
Set MySel2 = Union(MySel2, .Cells(rw2, 1).EntireRow)
End If
End If
Next rw2
End With
With ThisWorkbook.Worksheets("Sheet4")
lastrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel2 Is Nothing Then
MySel2.Copy Destination:=.Cells(lastrow2 + 1, 1)
'MySel2.Delete
End If
End With
Dim rw3 As Long, lastrow3 As Long, MySel3 As Range 'Grabs skus and moves to new sheet
With Worksheets("Sheet1")
For rw3 = 1000 To 2 Step -1
If .Cells(rw3, 1).Value Like "*44-*" Then
If MySel3 Is Nothing Then
Set MySel3 = .Cells(rw3, 1).EntireRow
Else
Set MySel3 = Union(MySel3, .Cells(rw3, 1).EntireRow)
End If
End If
Next rw3
End With
With ThisWorkbook.Worksheets("Sheet5")
lastrow3 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel3 Is Nothing Then
MySel3.Copy Destination:=.Cells(lastrow3 + 1, 1)
'Mysel3.Delete
End If
End With
Dim rw4 As Long, lastrow4 As Long, MySel4 As Range 'Grabs skus and moves to new sheet
With Worksheets("Sheet1")
For rw4 = 1000 To 2 Step -1
If .Cells(rw4, 1).Value Like "*55-*" Then
If MySel4 Is Nothing Then
Set MySel4 = .Cells(rw4, 1).EntireRow
Else
Set MySel4 = Union(MySel4, .Cells(rw4, 1).EntireRow)
End If
End If
Next rw4
End With
With ThisWorkbook.Worksheets("Sheet6")
lastrow4 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel4 Is Nothing Then
MySel4.Copy Destination:=.Cells(lastrow4 + 1, 1)
'MySel4.Delete
End If
End With
Workbooks.Open Filename:="C:\CODE\11 Production.xlsx"
Workbooks.Open Filename:="C:\CODE\22 Production.xlsx"
Workbooks.Open Filename:="C:\CODE\33 Production.xlsx"
Workbooks.Open Filename:="C:\CODE\44 Production.xlsx"
Workbooks.Open Filename:="C:\CODE\55 Production.xlsx"
Dim Rng As Range
Set Rng = ThisWorkbook.Worksheets("Sheet2").Range("A1:AY300")
Rng.Copy
Dim s11 As Workbook
Set s11 = Workbooks("11 Production")
Dim last As Long
Dim Rngnew As Range
With s11.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
last = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
last = 1
End If
End With
Set Rngnew = s11.Worksheets("Sheet1").Range("A" & last)
Rngnew.PasteSpecial
Dim Rng22 As Range
Set Rng22 = ThisWorkbook.Worksheets("Sheet3").Range("A1:AY300")
Rng22.Copy
Dim s22 As Workbook
Set s22 = Workbooks("22 Production")
Dim last22 As Long
Dim Rng22new As Range
With s22.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
last22 = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
last22 = 1
End If
End With
Set Rng22new = s22.Worksheets("Sheet1").Range("A" & last)
Rng22new.PasteSpecial
Dim Rng33 As Range
Set Rng33 = ThisWorkbook.Worksheets("Sheet4").Range("A1:AY300")
Rng33.Copy
Dim s33 As Workbook
Set s33 = Workbooks("33 Production")
Dim last33 As Long
Dim Rng33new As Range
With s33.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
last33 = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
last33 = 1
End If
End With
Set Rng33new = s33.Worksheets("Sheet1").Range("A" & last)
Rng33new.PasteSpecial
Dim Rng44 As Range
Set Rng44 = ThisWorkbook.Worksheets("Sheet5").Range("A1:AY300")
Rng44.Copy
Dim s44 As Workbook
Set s44 = Workbooks("44 Production")
Dim last44 As Long
Dim Rng44new As Range
With s44.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
last44 = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
last44 = 1
End If
End With
Set Rng44new = s44.Worksheets("Sheet1").Range("A" & last)
Rng44new.PasteSpecial
Dim Rng55 As Range
Set Rng55 = ThisWorkbook.Worksheets("Sheet6").Range("A1:AY300")
Rng55.Copy
Dim s55 As Workbook
Set s55 = Workbooks("55 Production")
Dim last55 As Long
Dim Rng55new As Range
With s55.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
last55 = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
last55 = 1
End If
End With
Set Rng55new = s55.Worksheets("Sheet1").Range("A" & last)
Rng55new.PasteSpecial
If MsgBox("Would you like to populate the team lists?", vbOKCancel) = vbOK Then
'run your code
Workbooks("11 Production").Activate
Dim newRwChr As Long
With Worksheets("Sheet1")
For newRwChr = 1000 To 2 Step -1
If Right(.Cells(newRwChr, 3).Value, 1) = Chr(34) Then
.Cells(newRwChr, 3).Value = Left(.Cells(newRwChr, 3).Value, Len(.Cells(newRwChr, 3).Value) - 1)
End If
Next newRwChr
End With
Dim newRw As Long, NewRngRow As Long, NewMySel As Range 'Grabs skus and moves to new sheet
Dim News11 As Workbook
With Worksheets("Sheet1")
For newRw = 1000 To 2 Step -1
If .Cells(newRw, 2).Value Like "*Minor Novice*" And .Cells(newRw, 3).Value Like ("*AE*") Then
If NewMySel Is Nothing Then
Set NewMySel = .Cells(newRw, 1).EntireRow
Set News11 = Workbooks.Open(Filename:="C:\CODE\Team Lists\11 Minor Novice AE.xlsx")
Else
Set NewMySel = Union(NewMySel, .Cells(newRw, 1).EntireRow)
End If
End If
Next newRw
End With
Workbooks("11 Production").Activate
With Workbooks("11 Production").Worksheets("M Novice AE")
NewRngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not NewMySel Is Nothing Then
NewMySel.Copy Destination:=.Cells(NewRngRow + 1, 1)
'NewMySel.Delete
End If
End With
If Not News11 Is Nothing Then
Dim NewRng As Range
Set NewRng = Workbooks("11 Production").Worksheets("M Novice AE").Range("A1:AY300")
NewRng.Copy
Dim NewLast As Long
Dim NewRngnew As Range
With News11.Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
NewLast = .Range("A65000").End(xlUp).Offset(1, 0).Row
Else
NewLast = 1
End If
End With
Set NewRngnew = News11.Worksheets("Sheet1").Range("A" & NewLast)
NewRngnew.PasteSpecial
End If
部分是消息框针对不同条件重复50次
答案 0 :(得分:0)
例如,除了声明6个单独的工作表外,您可以执行类似的操作
Dim ws(1 To 6) As Worksheet, i As Long
For i = 1 To 6
Set ws(i) = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Next i
现在您可以使用ws(1)
,ws(2)
等
或者不要重复此过程的变体:
With Worksheets("orders (3)")
For rwqty2 = 1000 To 2 Step -1
If .Cells(rwqty2, 25).Value Like "*2*" Then
If MySelqty2 Is Nothing Then
Set MySelqty2 = .Cells(rwqty2, 1).EntireRow
Else
Set MySelqty2 = Union(MySelqty2, .Cells(rwqty2, 1).EntireRow)
End If
End If
Next rwqty2
End With
With ThisWorkbook.Worksheets("orders (3)")
lastrowqty2 = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySelqty2 Is Nothing Then
MySelqty2.Copy Destination:=.Cells(lastrowqty2 + 1, 1)
'MySelqty3.Delete
End If
End With
您可以像这样制作一个子:
'search rows for a match, copy all matches to rngDest
' delete copied rows if deleteAfterCopy=True
Sub CopyRowMatches(rngSrc As Range, crit, rngDest As Range, _
Optional deleteAfterCopy As Boolean = False)
Dim c As Range, rngCopy As Range
For Each c In rngSrc.Cells
If c.Value Like crit Then BuildRange rngCopy, c
Next c
If Not rngCopy Is Nothing Then
rngCopy.Copy rngDest
If deleteAfterCopy Then rngCopy.Delete
End If
End Sub
'utility sub to build a range using Union
Sub BuildRange(rngToBuild As Range, rngToAdd As Range)
If Not rngToBuild Is Nothing Then
Set rngToBuild = Application.Union(rngToBuild, rngToAdd)
Else
Set rngToBuild = rngToAdd
End If
End Sub
...并这样称呼它:
CopyRowMatches ws(1).Cells(2, 25).Resize(999), "*2*", _
ws(1).Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)