Мой код VBA занимает слишком много времени, какие-либо предложения о том, как сократить время? Для петли - PullRequest
Новая
       1

Мой код VBA занимает слишком много времени, какие-либо предложения о том, как сократить время? Для петли

0 голосов
/ 02 ноября 2019

Мой код предназначен для открытия файла, копирования содержимого файла, вставки его в рабочий файл с формулами. Формулы определяют, следует ли игнорировать строку. Затем код проходит через каждую строку и копирует строку с «игнорированием» в другую вкладку, а затем удаляет строку. Затем код проверяет, является ли «INV NOT FOUND» строкой, имеющей это обозначение, затем он скопирует строку в новую рабочую книгу и, пройдя все строки, закроет и сохранит новую книгу. У меня есть некоторые файлы, которые имеют 5k + строк, и это занимает слишком много времени.

Я не совсем уверен, как еще можно закодировать цикл. 

Option Explicit

Sub RawData()
Dim CurrentDate As String
Dim PB As String
Dim ReturnsCheck As String
Dim Filename As String
Dim MyRange As String
Dim aWB As Workbook
Dim tWB As Workbook, newSheet As Worksheet
Dim MissingInvCount As Long
Dim rng As Range
Dim cell As Range
Dim search As String

Set tWB = ThisWorkbook

CurrentDate = Range("C6")
PB = Range("C8")

Application.EnableCancelKey = xlDisabled

Worksheets("data table").Visible = True

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Worksheets("sort area").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
    Worksheets("pershing").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
    Worksheets("jpm").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
    Worksheets("gs").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
    Worksheets("ms").Visible = True

End If

'Opens Raw file
    Workbooks.Open Filename:="G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Raw Files\" & "Raw File - " & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"


ActiveWorkbook.Activate
Set aWB = ActiveWorkbook

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    aWB.Activate
       Range("A1", Range("CZ" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("sort area").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
    aWB.Activate
       Range("A1", Range("U" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("pershing").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
    aWB.Activate
       Range("A1", Range("AD" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("jpm").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
    aWB.Activate
       Range("A1", Range("V" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("gs").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
    aWB.Activate
       Range("A1", Range("L" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("ms").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

'Closes Raw File w/o saving
    aWB.Close SaveChanges:=False

'Copy Formulas down
Dim Lastrow As Long

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Worksheets("sort area").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("DB2:FN" & Lastrow).FillDown
ElseIf Range("PB") = "Pershing" Then
    Worksheets("pershing").Activate
    Lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Range("W2:BO" & Lastrow).FillDown
ElseIf Range("PB") = "JPM" Then
    Worksheets("jpm").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("AI2:CU" & Lastrow).FillDown
ElseIf Range("PB") = "Goldman Sachs" Then
    Worksheets("gs").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("X2:CJ" & Lastrow).FillDown
ElseIf Range("PB") = "Morgan Stanley" Then
    Worksheets("ms").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("N2:BZ" & Lastrow).FillDown

End If

'Remove ignored lines & Idenitifies missing investments

Dim n As Integer
Dim nLastRow As Long
Dim nFirstRow As Long
Dim r As Range


    Set r = ActiveSheet.UsedRange
    nLastRow = Lastrow - 1
    nFirstRow = 2


Dim i As Long: i = 1

With ActiveSheet
    On Error Resume Next
    Application.ScreenUpdating = False

    If tWB.Worksheets("home").Range("PB") = "Citi" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "DB") = "IGNORE" Then
                .Cells(n, "DB").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "DB").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Pershing" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "W") = "IGNORE" Then
                .Cells(n, "W").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "W").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "JPM" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "AI") = "IGNORE" Then
                .Cells(n, "AI").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "AI").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Goldman Sachs" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "X") = "IGNORE" Then
                .Cells(n, "X").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "X").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Morgan Stanley" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "N") = "IGNORE" Then
                .Cells(n, "N").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "N").EntireRow.Delete
                i = i + 1
            End If
        Next

    End If
End With

'Sort Ignore tab
Worksheets("ignore").Activate
Lastrow = Cells(Rows.Count, 2).End(xlUp).Row

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Range("A1:FG" & Lastrow).SORT key1:=Range("DE1:DE" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Pershing" Then
    Range("A1:BO" & Lastrow).SORT key1:=Range("Z1:Z" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "JPM" Then
    Range("A1:CU" & Lastrow).SORT key1:=Range("AL1:AL" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Goldman Sachs" Then
    Range("A1:CJ" & Lastrow).SORT key1:=Range("AA1:AA" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Morgan Stanley" Then
    Range("A1:BZ" & Lastrow).SORT key1:=Range("Q1:Q" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

End If

'Missing investments

If tWB.Worksheets("home").Range("PB") = "Citi" Then

Worksheets("sort area").Activate
Set rng = ActiveSheet.Range("DF1:DF" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("sort area").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "DF") = "INV NOT FOUND" Then
                    .Cells(n, "DF").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "DF").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Pershing" Then

Worksheets("pershing").Activate
Set rng = ActiveSheet.Range("AA1:AA" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("pershing").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AA") = "INV NOT FOUND" Then
                    .Cells(n, "AA").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AA").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "JPM" Then

Worksheets("jpm").Activate
Set rng = ActiveSheet.Range("AM1:AM" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("jpm").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AM") = "INV NOT FOUND" Then
                    .Cells(n, "AM").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AM").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Goldman Sachs" Then

Worksheets("gs").Activate
Set rng = ActiveSheet.Range("AB1:AB" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("gs").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AB") = "INV NOT FOUND" Then
                    .Cells(n, "AB").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AB").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Morgan Stanley" Then

Worksheets("ms").Activate
Set rng = ActiveSheet.Range("R1:R" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("ms").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "R") = "INV NOT FOUND" Then
                    .Cells(n, "R").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "R").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If MissingInvCount <> 0 Then
MsgBox ("There are " & MissingInvCount & " missing investments.")
End If

'Sort Missing Investments tab
If MissingInvCount <> 0 Then

    newSheet.Activate
    Lastrow = Cells(Rows.Count, 2).End(xlUp).Row

    If tWB.Worksheets("home").Range("PB") = "Citi" Then
        Range("A1:FN" & Lastrow).SORT key1:=Range("DC1:DC" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("DD:FN").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
        Range("A1:CI" & Lastrow).SORT key1:=Range("X1:X" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("Y:FN").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
        Range("A1:CU" & Lastrow).SORT key1:=Range("AJ1:AJ" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("AK:CU").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
     Range("A1:CJ" & Lastrow).SORT key1:=Range("Y1:Y" & Lastrow), _
         order1:=xlAscending, Header:=xlNo
     Columns("Z:CJ").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
     Range("A1:BZ" & Lastrow).SORT key1:=Range("O1:O" & Lastrow), _
         order1:=xlAscending, Header:=xlNo
     Columns("P:BZ").EntireColumn.Delete

    End If

    'Save flat file
    Dim strFullname As String
    Dim strFullname2 As String

    strFullname = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Investments Pending Creation\" & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"
    strFullname2 = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Ignored\" & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"

    Application.DisplayAlerts = False

    ThisWorkbook.ActiveSheet.Move
    ActiveWorkbook.SaveAs Filename:=strFullname, FileFormat:=xlCSV, CreateBackup:=True
    ActiveWorkbook.Close

    ThisWorkbook.Worksheets("ignore").Copy
    ActiveWorkbook.SaveAs Filename:=strFullname2, FileFormat:=xlCSV, CreateBackup:=True
    ActiveWorkbook.Close

End If

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Sheets("home").Activate

End Sub

Я хотел бы закодировать, чтобы закончить вдо 5 минут, если это возможно.

1 Ответ

0 голосов
/ 02 ноября 2019

Непосредственно перед (или сразу после) этим утверждением: 

Set tWB = ThisWorkbook

добавьте это: 

  With Application
    .CalculateFull
    .EnableEvents = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With

Затем в конце замените эти две строки: 

Application.DisplayAlerts = True
Application.ScreenUpdating = True

с: 

  With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...