Как оптимизировать несколько циклов в коде VBA в Excel - PullRequest
Новая
       1

Как оптимизировать несколько циклов в коде VBA в Excel

0 голосов
/ 02 мая 2019

Я не очень эффективный VBA-кодер, но я могу грубо пробиться через что-то.Я пытаюсь оптимизировать этот код, чтобы он работал быстрее.Я полагаю, что можно каким-то образом комбинировать циклы, но я не совсем уверен, с чего начать, поскольку таблицы находятся в формулах.Будем очень благодарны любой помощи.

Sub Import()

Application.EnableEvents = False 'This stops the background codes on the sheets from activating (smoothens out the process).
Application.ScreenUpdating = False 'Stops the screen from switching back and forth between the Input and the Master
Application.DisplayAlerts = False

If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
Else:
    Sheets("SHEET1").Columns("KA:KC").Hidden = True
    Sheets("SHEET2").Columns("KA:KC").Hidden = True
    Sheets("SHEET3").Columns("KA:KC").Hidden = True
    Sheets("SHEET4").Columns("KA:KC").Hidden = True
    MsgBox "Doesn't exist for these locations"
    Exit Sub
End If
    Sheets("SHEET1").Columns("KA:KC").Hidden = False
    Sheets("SHEET2").Columns("KA:KC").Hidden = False
    Sheets("SHEET3").Columns("KA:KC").Hidden = False
    Sheets("SHEET4").Columns("KA:KC").Hidden = False

`'This removes the old DATASHEET tab from the model before starting (if it exists)
Dim SummaryWB As Workbook
Dim vrtSelectedItem As Variant
  For Each Sheet In ActiveWorkbook.Worksheets
     If Sheet.Name = "DATASHEET" Then
          Sheet.Delete
     End If
  Next Sheet

''' The below opens the RRS file from the file path defined
Workbooks.Open Filename:="\\Template_Current.xlsx"


'' This just pauses the operating for 1 second to allow the file to be opened seamlessly, can probably be removed.
Application.Wait Now + #12:00:01 AM#


'' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
'' It then closes the Source file.

Sheets("Data").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("YAdd").Select
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Select
ActiveSheet.Name = "DATASHEET"
Windows("Template_Current.xlsx").Activate
Sheets("List View").Select
Range("D3").Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("DATASHEET").Select
Range("W1").Select
ActiveSheet.Paste
Windows("Template_Current.xlsx").Activate
ActiveWorkbook.Close True
Windows("Report.xlsm").Activate


'' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
'' shows values if they are found/non-zero.  It also clears old data from the columns
'' This also copies the outputed data and pastes only the values.
'' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
'' the file, only when you run this macro.

Sheets("SHEET1").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow As Long, i As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 25 To LastRow
    Range("KA1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET1!RC[-1]="""","""",If(SHEET1!RC[-1]>1.1,""RED"",If(SHEET1!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET1!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i

Sheets("SHEET1").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET2").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow1 As Long, i1 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i1 = 25 To LastRow
    Range("KA1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET2!RC[-1]="""","""",If(SHEET2!RC[-1]>1.1,""RED"",If(SHEET2!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET2!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i1

Sheets("SHEET2").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET3").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow2 As Long, i2 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i2 = 25 To LastRow
    Range("KA1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET3!RC[-1]="""","""",If(SHEET3!RC[-1]>1.1,""RED"",If(SHEET3!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET3!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i2

Sheets("SHEET3").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET4").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow3 As Long, i3 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i3 = 25 To LastRow
    Range("KA1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET4!RC[-1]="""","""",If(SHEET4!RC[-1]>1.1,""RED"",If(SHEET4!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET4!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i3

Sheets("SHEET4").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select

Sheets("DATASHEET").Visible = xlSheetHidden

Application.EnableEvents = True 'Turns background code back on.
Application.ScreenUpdating = True 'Turns ScreenUpdating back on.
Application.DisplayAlerts = True 'Turns Alerts back on.

MsgBox "Import Complete"

End Sub

1 Ответ

0 голосов
/ 07 мая 2019

Вы хотите избежать повторения.Всякий раз, когда у вас есть повторяющийся код, вам нужно разбить его на собственную процедуру, а затем вызвать его, используя переменную, которая делает его уникальным.В вашем случае единственной уникальной частью является лист, на котором вы работаете.Итак, я создал этот пример процедуры, которую вы можете передавать объектам листа: 

Private Sub ProcessSheet(thisSheet As Worksheet)

    thisSheet.Range("KA25:KC5000").Delete

    Dim LastRow As Long, i As Long
    LastRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row
    For i = 25 To LastRow
        thisSheet.Range("KA1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

        thisSheet.Range("KB1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(" & thisSheet.Name & "!RC[-1]="""","""",If(" & thisSheet.Name & "!RC[-1]>1.1,""RED"",If(" & thisSheet.Name & "!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

        thisSheet.Range("KC1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(" & thisSheet.Name & "!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
    Next i

    With thisSheet
        .Range("KA25").UsedRange = Sheets("SHEET1").Range("KA25").UsedRange
        .Range("KA25", Selection.End(xlDown)).NumberFormat = "0.00"
        .Range("KC25", Selection.End(xlDown)).NumberFormat = "0.00%"
    End With
End Sub

Затем вы можете вызывать ее из основной процедуры импорта следующим образом: 

Sub Import()
    With Application
        .EnableEvents = False             'This stops the background codes on the sheets from activating (smoothens out the process).
        .ScreenUpdating = False           'Stops the screen from switching back and forth between the Input and the Master
        .DisplayAlerts = False
    End With

    If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    Else
        Sheets("SHEET1").Columns("KA:KC").Hidden = True
        Sheets("SHEET2").Columns("KA:KC").Hidden = True
        Sheets("SHEET3").Columns("KA:KC").Hidden = True
        Sheets("SHEET4").Columns("KA:KC").Hidden = True
        MsgBox "Doesn't exist for these locations"
        Exit Sub
    End If

    Sheets("SHEET1").Columns("KA:KC").Hidden = False
    Sheets("SHEET2").Columns("KA:KC").Hidden = False
    Sheets("SHEET3").Columns("KA:KC").Hidden = False
    Sheets("SHEET4").Columns("KA:KC").Hidden = False

    'This removes the old DATASHEET tab from the model before starting (if it exists)
    Dim SummaryWB As Workbook
    Dim vrtSelectedItem As Variant
    For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name = "DATASHEET" Then
            Sheet.Delete
        End If
    Next Sheet

    ''' The below opens the RRS file from the file path defined
    Dim RRSFile As Workbook
    Set RRSFile = Workbooks.Open(Filename:="\\Template_Current.xlsx")

    '' This will allow the workbook to open before continuing
    DoEvents

    '' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
    '' It then closes the Source file.
    Dim dataRange As Range
    dataRange = RRSFile.Sheets("Data").Range("A1").UsedRange

    Dim dataSheet As Worksheet
    Windows("Report.xlsm").Activate
    Set dataSheet = Sheets.Add(After:=Sheets("YAdd"))
    dataSheet.Range("A1") = dataRange
    dataSheet.Name = "DATASHEET"
    RRSFile.Sheets("List View").Range ("D3")
    dataSheet.Range("W1") = RRSFile.Sheets("List View").Range("D3")
    RSSFile.Close True
    Windows("Report.xlsm").Activate


    '' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
    '' shows values if they are found/non-zero.  It also clears old data from the columns
    '' This also copies the outputed data and pastes only the values.
    '' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
    '' the file, only when you run this macro.

    ProcessSheet Sheets("SHEET1")
    ProcessSheet Sheets("SHEET2")
    ProcessSheet Sheets("SHEET3")
    ProcessSheet Sheets("SHEET4")

    Sheets("DATASHEET").Visible = xlSheetHidden

    With Application
        .EnableEvents = True              'Turns background code back on.
        .ScreenUpdating = True            'Turns ScreenUpdating back on.
        .DisplayAlerts = True             'Turns Alerts back on.
    End With

    MsgBox "Import Complete"

End Sub

Большое преимущество, которое вы получаетездесь вы можете изменить этот код в одном месте, и это повлияет на все 4 ваших цикла.Вместо того, чтобы пытаться сохранить 4 идентичные копии одного и того же кода.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

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

...