尝试让消息框从单独的过程运行代码

时间:2019-08-15 14:05:58

标签: excel vba

我有大约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次

1 个答案:

答案 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)