Оптимизировать медленный ответ VBA - PullRequest
Новая
       0

Оптимизировать медленный ответ VBA

0 голосов
/ 27 мая 2020

Мне нужно оптимизировать код vba, используемый для обновления базы данных в моей электронной таблице. Было бы здорово, если бы я смог получить максимально оптимизированный код. Этот макрос помещает конвертацию валют непосредственно в отчет, и вам нужно будет вычислить их (на вкладке «Обмены», которую создает этот отчет, используются исторические обменные курсы) 

Sub ZKDP5M()

  Application.ScreenUpdating = False

'Add New sheet for marketplace and currency conversions
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Name = "Exchange Rates"
    Range("A1").Select

' Add Marketplaces and Exchange Rates under a new tab
' Update the exchange rates on this tab with the exchange rates under the "Payment" tab of your KDP Report each month to get accurate royalties.

    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Marketplace"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Conversion Rate"
    Range("B2").Select
    Columns("A:A").EntireColumn.AutoFit
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "US"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "UK"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "1.35"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "DE"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "1.12"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "JP"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "0.01"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "CA"
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "0.76"
    Range("A7").Select
    ActiveCell.FormulaR1C1 = "IT"
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "1.12"
    Range("A8").Select
    ActiveCell.FormulaR1C1 = "ES"
    Range("B8").Select
    ActiveCell.FormulaR1C1 = "1.11"
     Range("A9").Select
    ActiveCell.FormulaR1C1 = "FR"
    Range("B9").Select
    ActiveCell.FormulaR1C1 = "1.68"
    Range("A10").Select
    ActiveCell.FormulaR1C1 = "NL"
    Range("B10").Select
    ActiveCell.FormulaR1C1 = "1.12"
    Range("A11").Select
    ActiveCell.FormulaR1C1 = "IN"
    Range("B11").Select
    ActiveCell.FormulaR1C1 = "0.01"
    Range("A12").Select
    ActiveCell.FormulaR1C1 = "AU"
    Range("B12").Select
    ActiveCell.FormulaR1C1 = "0.72"
    Range("A13").Select
    ActiveCell.FormulaR1C1 = "BR"
    Range("B13").Select
    ActiveCell.FormulaR1C1 = "0.26"
    Range("A14").Select
    ActiveCell.FormulaR1C1 = "MX"
    Range("B14").Select
    ActiveCell.FormulaR1C1 = "0.05"
    Range("B15").Select
    Columns("B:B").EntireColumn.AutoFit
    Range("A1:B1").Select
    Selection.Font.Bold = True

'Preserve Data
'This preserves the original data in your report in case you need it.

    Sheets("KENP Read").Select
    Sheets.Add
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "KENPBeforeConversion"
    Sheets("KENP Read").Select
    Range("A1:G2").Select
    Selection.Copy
    Sheets("KENPBeforeConversion").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("KENP Read").Select
    Range("E20").Select
    Sheets("KENP Read").Select
    Application.CutCopyMode = False


'Columns Work
'I included a "Retailer" column for my own purposes, but this may be useful to you if you want to aggregate this report onto a master spreadssheet. You can simply delete or hide if you do not need it.

 Range("A1").Select
  Selection.EntireRow.Delete
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Retailer"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Month"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Year"
    Columns("B:C").Select
    Columns("B:C").EntireColumn.AutoFit
    Range("A2").Select
    Columns("A:A").ColumnWidth = 20.05
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "KENP"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "GBP Conversion"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "DE Conversion"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "JPY Conversion"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "CAD Conversion"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "EUR IT Conversion"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "EUR ES Conversion"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "EUR FR Conversion"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "EUR NL Conversion"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "INR Conversion"
    Range("T1").Select
    ActiveCell.FormulaR1C1 = "AUD Conversion"
    Range("U1").Select
    ActiveCell.FormulaR1C1 = "BRL Conversion"
    Range("V1").Select
    ActiveCell.FormulaR1C1 = "MXN Conversion"
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "USD Conversion"
    Range("X1").Select
    ActiveCell.FormulaR1C1 = "AdjustedIncome"
    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "AdjustedCurrency"
    Columns("K:Y").Select
    Range("Y1").Activate
    Columns("K:Y").EntireColumn.AutoFit
    Columns("D:D").ColumnWidth = 37.36

'Currency Conversions

'GBP Currency Conversion

Range("K2").Select
    ActiveCell.Formula = "=IF(G2=""UK"",'Exchange Rates'!$B$3*I2,0)"

    Range("K2").Select

Range("K2").AutoFill Destination:=Range("K2:K1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'DE Currency Conversion

Range("L2").Select
    ActiveCell.Formula = "=IF(G2=""DE"",'Exchange Rates'!$B$4*I2,0)"

    Range("L2").Select

Range("L2").AutoFill Destination:=Range("L2:L1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'JPY Currency Conversion

Range("M2").Select
    ActiveCell.Formula = "=IF(G2=""JP"",'Exchange Rates'!$B$5*I2,0)"

    Range("M2").Select

Range("M2").AutoFill Destination:=Range("M2:M1000" & Cells(Rows.Count, "D").End(xlUp).Row)


'CAD Currency Conversion
Range("N2").Select
    ActiveCell.Formula = "=IF(G2=""CA"",'Exchange Rates'!$B$6*I2,0)"

    Range("N2").Select

Range("N2").AutoFill Destination:=Range("N2:N1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'EUR IT Currency Conversion
Range("O2").Select
    ActiveCell.Formula = "=IF(G2=""IT"",'Exchange Rates'!$B$7*I2,0)"

    Range("O2").Select

Range("O2").AutoFill Destination:=Range("O2:O1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'EUR ES Currency Converter

Range("P2").Select
    ActiveCell.Formula = "=IF(G2=""ES"",'Exchange Rates'!$B$8*I2,0)"

    Range("P2").Select

Range("P2").AutoFill Destination:=Range("P2:P1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'EUR FR Currency Conversion
Range("Q2").Select
    ActiveCell.Formula = "=IF(G2=""FR"",'Exchange Rates'!$B$9*I2,0)"

    Range("Q2").Select

Range("Q2").AutoFill Destination:=Range("Q2:Q1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'EUR NL Currency Conversion

Range("R2").Select
    ActiveCell.Formula = "=IF(G2=""NL"",'Exchange Rates'!$B$10*I2,0)"

    Range("R2").Select

Range("R2").AutoFill Destination:=Range("R2:R1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'INR Currency Conversion

Range("S2").Select
    ActiveCell.Formula = "=IF(G2=""IN"",'Exchange Rates'!$B$11*I2,0)"

    Range("S2").Select

Range("S2").AutoFill Destination:=Range("S2:S1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'AUD Currency Conversion

Range("T2").Select
    ActiveCell.Formula = "=IF(G2=""AU"",'Exchange Rates'!$B$12*I2,0)"

    Range("T2").Select

Range("T2").AutoFill Destination:=Range("T2:T1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'BRL Currency Conversion

Range("U2").Select
    ActiveCell.Formula = "=IF(G2=""BR"",'Exchange Rates'!$B$13*I2,0)"

    Range("U2").Select

Range("U2").AutoFill Destination:=Range("U2:U1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'MXN Currency Conversion

Range("V2").Select
    ActiveCell.Formula = "=IF(G2=""MX"",'Exchange Rates'!$B$14*I2,0)"

    Range("V2").Select

Range("V2").AutoFill Destination:=Range("V2:V1000" & Cells(Rows.Count, "D").End(xlUp).Row)

'USD Currency Conversion
Range("W2").Select
    ActiveCell.Formula = "=IF(G2=""US"",'Exchange Rates'!$B$2*I2,0)"

    Range("W2").Select

Range("W2").AutoFill Destination:=Range("W2:W1000" & Cells(Rows.Count, "D").End(xlUp).Row)


'Find and Replace illegal characters

Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long

fndList = Array("N/A", "Amazon.com.au", "Amazon.com.br", "Amazon.com.mx", "Amazon.com", "Amazon.co.uk", "Amazon.co.jp", "Amazon.ca", "Amazon.it", "Amazon.fr", "Amazon.es", "Amazon.nl", "Amazon.in", "Amazon.de")
rplcList = Array("0", "AU", "BR", "MX", "US", "UK", "JP", "CA", "IT", "FR", "ES", "NL", "IN", "DE")

'Loop through each item in Array lists
  For x = LBound(fndList) To UBound(fndList)
    'Loop through each worksheet in ActiveWorkbook
      For Each sht In ActiveWorkbook.Worksheets
        sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
          SearchFormat:=False, ReplaceFormat:=False
      Next sht

  Next x


'Royalty Month autofill
'Get filename

Range("AH2") = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
Range("AH2").Select
Selection.Copy
Range("AI2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Range("AJ2").Select
    ActiveCell.FormulaR1C1 = "=MID(RC[-1],27,4)"
Range("AJ2").Select
Selection.Copy
Range("C2:C1000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'RoyaltyYear Autofill

Range("AK2").Select
    ActiveCell.FormulaR1C1 = "=MID(RC[-2],32,2)"
Range("AK2").Select
Selection.Copy
Range("B2:B1000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Retailer Column Autofill

    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Kindle Unlimited"
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A1000"), Type:=xlFillDefault
    Range("A2").Select

'Delete unnecessary cells
    Range("AH2:AK2").Select
    Selection.ClearContents

'Final Cleanup work


    Columns("K:K").Select
    Selection.ColumnWidth = 22.57
    Columns("L:W").Select
    Selection.NumberFormat = "$#,##0.00"
    Columns("K:K").Select
    Selection.Style = "Currency"
    Selection.NumberFormat = "$#,##0.00"
    Range("W2").Select

       Range("X2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-13]:RC[-1])"
    Range("X2").Select
    Selection.AutoFill Destination:=Range("X2:X48"), Type:=xlFillDefault
    Range("X2:X48").Select

       Range("Y2").Select
    ActiveCell.FormulaR1C1 = "USD"
    Range("Y2").Select
    Selection.AutoFill Destination:=Range("Y2:Y48"), Type:=xlFillDefault

        Columns("K:W").Select
    Selection.EntireColumn.Hidden = True

'Delete empty rows in Retailer Column if Title Column is blank

On Error Resume Next
Columns("D").SpecialCells(xlBlanks).EntireRow.Delete

'Delete Adjusted Currency Column as no longer needed

    Columns("AG:AG").Select
    Selection.Delete Shift:=xlToLeft

'Format KENP column as General text

        Columns("H").Select
    Selection.NumberFormat = "General"

'Save as CSV to directory

'ActiveWorkbook.SaveAs FileName:= _
'"C:\Royalties\KDP\KDP.csv", FileFormat:=xlCSV, CreateBackup:=False

Application.DisplayAlerts = False

Dim fn As String
Dim l As Long
Dim wb As Workbook

Set wb = ActiveWorkbook
fn = wb.FullName
l = InStrRev(fn, ".")
fn = Left(fn, l)
fn = fn & "csv"

wb.SaveAs fileName:=fn, FileFormat:=xlCSV

Application.DisplayAlerts = False


        Range("A2").Select

End Sub

1 Ответ

2 голосов
/ 27 мая 2020

Вот два совета:

1: Комментарий от barvobot - хороший подход:

Добавьте следующий код в начало вашей подпрограммы, чтобы отключить вычисления и обновление экрана: 

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

В конце вашей подпрограммы снова активируйте расчет и обновите экран: 

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Это ускорит ваш код.

2: Вы много работаете с .select. Я считаю, что это не лучший подход. Вот мое предложение:

Используйте переменную рабочего листа для вашего нового листа. Поэтому замените свой код: 

'Add New sheet for marketplace and currency conversions
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Name = "Exchange Rates"
Range("A1").Select

на: 

Dim ws As Worksheet
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = "Exchange Rates"

Используйте переменную рабочего листа для установки значений и замените .select. Вот пример:

заменить: 

Range("A2").Select
ActiveCell.FormulaR1C1 = "US"
Range("B2").Select
ActiveCell.FormulaR1C1 = "1"
Range("A3").Select
ActiveCell.FormulaR1C1 = "UK"

на: 

ws.Range("A2").value = "US"
ws.Range("B2").value = "1"
ws.Range("A3").value = "UK"

Это значительно сократит ваш код.

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

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

...