Refine a VBA script

lloydie8

New Member
Joined
Sep 5, 2017
Messages
23
Hi guys

I have written a VBA script that is quite lengthy. I've written it taking bits and pieces of seen others post, and then amended for my requirement.

To aid performance and save on memory/disk space, can anyone help me (using your expertise instead of my newbie knowledge and) refine the below script, taking out any unnecessary lines and amending any lines that require so?

The script runs sequentially so the ordering shouldn't be tampered with.

Code:
Sub EGBCIS13()

'Adds and names the two Worksheets needed
Dim ws As Worksheet
Set ws = Sheets.Add(Before:=Worksheets(1))
ws.Name = "EGBCIS13"
    
'Give all Worksheets an alias
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Set s1 = Sheets("EGBCIS13")
    Set s2 = Sheets("Instructions")
    Set s3 = Sheets("ForEx")
    Set s4 = Sheets("Template")
    Set s5 = Sheets("BUM")
    Set s6 = Sheets("PCS")
    Set s7 = Sheets("Ownership Update")


'Inserts the relevant column headers onto the "EGBCIS13" Worksheet
    s1.Range("A1").Value = "Company Code"
    s1.Range("B1").Value = "Company"
    s1.Range("C1").Value = "Center"
    s1.Range("D1").Value = "Division"
    s1.Range("E1").Value = "Cost Centre"
    s1.Range("F1").Value = "CC Lkp"
    s1.Range("G1").Value = "G/L Account No."
    s1.Range("H1").Value = "G/L Account Name"
    s1.Range("I1").Value = "PCS Code"
    s1.Range("J1").Value = "PCS Description"
    s1.Range("K1").Value = "PCS Code Amended"
    s1.Range("L1").Value = "PCS Description Amended"
    s1.Range("M1").Value = "Transactional Cluster"
    s1.Range("N1").Value = "Transactional Category"
    s1.Range("O1").Value = "Currency"
    s1.Range("P1").Value = "Invoice Posting Date"
    s1.Range("Q1").Value = "Year"
    s1.Range("R1").Value = "Month"
    s1.Range("S1").Value = "Invoice Number"
    s1.Range("T1").Value = "Invoice Date"
    s1.Range("U1").Value = "Invoice Line Text"
    s1.Range("V1").Value = "Qty"
    s1.Range("W1").Value = "Doc Type"
    s1.Range("X1").Value = "Doc Number"
    s1.Range("Y1").Value = "Doc Line No"
    s1.Range("Z1").Value = "CorrectNetValue"
    s1.Range("AA1").Value = "Amount Without VAT"
    s1.Range("AB1").Value = "VAT Amount"
    s1.Range("AC1").Value = "Total amount"
    s1.Range("AD1").Value = "Supplier Code"
    s1.Range("AE1").Value = "Supplier Name"
    s1.Range("AF1").Value = "Supplier Group"
    s1.Range("AG1").Value = "Supplier Default Cluster"
    s1.Range("AH1").Value = "Supplier Default Catgegory"
    s1.Range("AI1").Value = "Supplier Default PCS"
    s1.Range("AJ1").Value = "PO Number"
    s1.Range("AK1").Value = "PO Line Number"
    s1.Range("AL1").Value = "PO Type"
    s1.Range("AM1").Value = "PO date"
    s1.Range("AN1").Value = "PO Days Early"
    s1.Range("AO1").Value = "Retro Flag"
    s1.Range("AP1").Value = "UOM"
    s1.Range("AQ1").Value = "PO Line Text"
    s1.Range("AR1").Value = "Purchasing Group"
    s1.Range("AS1").Value = "Terms of Payment Key"
    s1.Range("AT1").Value = "Payment Term Desc"
    s1.Range("AU1").Value = "ProductCode"
    s1.Range("AV1").Value = "CC19"
    s1.Range("AW1").Value = "CC5"
    s1.Range("AX1").Value = "CC6"
    s1.Range("AY1").Value = "CC7"
    s1.Range("AZ1").Value = "CC10"
 
'Sets the Font and Font Size to be used on the "EGBCIS13" Worksheet
    s1.Range("A1:AZ1").Font.Name = "Calibri"
    s1.Range("A1:AZ1").Font.Size = 11


'Sets the Cell Colours for the relevant Column Headers used on the "EGBCIS13 Worksheet
    s1.Range("A1").Interior.Color = RGB(255, 255, 0)
    s1.Range("B1").Interior.Color = RGB(0, 176, 240)
    s1.Range("C1:E1").Interior.Color = RGB(255, 255, 0)
    s1.Range("F1").Interior.Color = RGB(0, 176, 240)
    s1.Range("G1:I1").Interior.Color = RGB(255, 255, 0)
    s1.Range("J1").Interior.Color = RGB(0, 176, 240)
    s1.Range("K1:N1").Interior.Color = RGB(255, 192, 0)
    s1.Range("O1:Y1").Interior.Color = RGB(255, 255, 0)
    s1.Range("Z1").Interior.Color = RGB(0, 176, 240)
    s1.Range("AA1:AE1").Interior.Color = RGB(255, 255, 0)
    s1.Range("AF1:AH1").Interior.Color = RGB(0, 176, 240)
    s1.Range("AI1").Interior.Color = RGB(255, 192, 0)
    s1.Range("AJ1:AM1").Interior.Color = RGB(255, 255, 0)
    s1.Range("AN1:AO1").Interior.Color = RGB(0, 176, 240)
    s1.Range("AP1:AU1").Interior.Color = RGB(255, 255, 0)
    s1.Range("AV1:AZ1").Interior.Color = RGB(0, 176, 240)


'Changes commas to decimal for monetary values
    LastRow1 = s4.Cells(Rows.Count, "V").End(xlUp).Row
    s4.Range("V2:V" & LastRow1).Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    LastRow2 = s4.Cells(Rows.Count, "X").End(xlUp).Row
    s4.Range("X2:X" & LastRow2).Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


'Adds leading "0" onto "PCS Code"
    LastRow1 = s4.Cells(Rows.Count, "H").End(xlUp).Row
    s4.Range("I2:I" & LastRow1).FormulaR1C1 = "=IF(OR(RC[-1]=0,TRIM(RC[-1])=""""),TRIM(RC[-1]),""0""&RC[-1])"
    s4.Range("I2:I1048576").Copy
    s4.Range("I2:I1048576").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    s4.Range("H2:H1048576").ClearContents
    s4.Range("I2:I1048576").Copy
    s4.Range("H2:H1048576").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    s4.Range("I2:I1048576").ClearContents


'Maps the relevant data where fields exists on both the "EGBCIS13" and "Template" Worksheets
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("A2:A" & LastRow2).Copy _
    Destination:=s1.Range("A" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "C").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("B2:D" & LastRow2).Copy _
    Destination:=s1.Range("C" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "G").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("E2:F" & LastRow2).Copy _
    Destination:=s1.Range("G" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "I").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("H2:H" & LastRow2).Copy _
    Destination:=s1.Range("I" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "O").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("J2:T" & LastRow2).Copy _
    Destination:=s1.Range("O" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "AA").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("V2:Z" & LastRow2).Copy _
    Destination:=s1.Range("AA" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "AJ").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("AB2:AE" & LastRow2).Copy _
    Destination:=s1.Range("AJ" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "AP").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("AF2:AF" & LastRow2).Copy _
    Destination:=s1.Range("AP" & LastRow1)
    LastRow1 = LastRow1 + 1
    LastRow1 = s1.Cells(Rows.Count, "AQ").End(xlUp).Row + 1
    LastRow2 = s4.Cells(Rows.Count, "A").End(xlUp).Row
    s4.Range("AJ2:AN" & LastRow2).Copy _
    Destination:=s1.Range("AQ" & LastRow1)
    LastRow1 = LastRow1 + 1


'Sets all non-blank cells in Column C (except Column Header) on the "BUM" WorkSheet as Number, not Text
    LastRow1 = s5.Cells(Rows.Count, "C").End(xlUp).Row
    With s5.Range("C2:C" & LastRow1)
     .Value = .Value
    End With


'Sets Name Ranges on the various worksheets ready for Lookup
    LastRow1 = s1.Cells(Rows.Count, "B").End(xlUp).Row + 1
    LastRow2 = s5.Cells(Rows.Count, "C").End(xlUp).Row
    s5.Range("C1:BP" & LastRow2).Name = "Company"
    LastRow1 = s1.Cells(Rows.Count, "F").End(xlUp).Row + 1
    LastRow2 = s5.Cells(Rows.Count, "A").End(xlUp).Row
    s5.Range("A1:BP" & LastRow2).Name = "CostCentre"
    LastRow1 = s1.Cells(Rows.Count, "J").End(xlUp).Row + 1
    LastRow2 = s6.Cells(Rows.Count, "A").End(xlUp).Row
    s6.Range("A1:B" & LastRow2).Name = "PCS"
    s3.Range("B18:C41").Name = "Currency"
    s3.Range("B11:C34").Name = "DomesticCurrency"
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s7.Cells(Rows.Count, "A").End(xlUp).Row
    s7.Range("A1:F" & LastRow2).Name = "OwnershipUpdate"
            
'Sets the relevant VLOOKUPs between the "EGBCIS13", "BUM" and "PCS" Worksheets
    LastRow1 = s1.Cells(Rows.Count, "B").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("B2:B" & LastRow2).Formula = "=VLOOKUP(A2,Company,2,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "F").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("F2:F" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,2,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "J").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("J2:J" & LastRow2).Formula = "=VLOOKUP(I2,PCS,2,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AF").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AF2:AF" & LastRow2).Formula = "=VLOOKUP(AD2,OwnershipUpdate,3,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AG").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AG2:AG" & LastRow2).Formula = "=VLOOKUP(AD2,OwnershipUpdate,4,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AH").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AH2:AH" & LastRow2).Formula = "=VLOOKUP(AD2,OwnershipUpdate,5,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AV").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AV2:AV" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,46,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AW").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AW2:AW" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,18,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AX").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AX2:AX" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,20,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AY").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AY2:AY" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,22,FALSE)"
    LastRow1 = s1.Cells(Rows.Count, "AZ").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AZ2:AZ" & LastRow2).Formula = "=VLOOKUP(E2,CostCentre,28,FALSE)"


'Performs the "PO Days Early" Calculation and sets the subsequent "Retro" flag
    LastRow1 = s1.Cells(Rows.Count, "AN").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AN2:AN" & LastRow2).Formula = "=T2-AM2"
    LastRow1 = s1.Cells(Rows.Count, "AO").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AO2:AO" & LastRow2).Formula = "=IF(AN2<""0"",""Retro"",""Non Retro"")"


'Perform currency conversion
    LastRow1 = s1.Cells(Rows.Count, "Z").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("Z2:Z" & LastRow2).Formula = "=IF(VLOOKUP(RC[-25],DomesticCurrency,2,FALSE)=RC[-11],RC[1]*VLOOKUP(RC[-11],Currency,2,FALSE),IF(RC[10]=0,RC[1]*VLOOKUP(RC[-11],Currency,2,FALSE),RC[3]*VLOOKUP(RC[-11],Currency,2,FALSE)))"


'Calculate the "Default PCS Code" for each Supplier
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("A1:AZ" & LastRow2).Name = "Template"
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Template", Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:="Sheet2!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion14
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Supplier Default PCS"
    Set s8 = Sheets("Supplier Default PCS")
    Cells(3, 1).Select
    s8.PivotTables("PivotTable1").PivotFields("PCS Code").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    s8.PivotTables("PivotTable1").PivotFields("CorrectNetValue"). _
        Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
        False, False)
    s8.PivotTables("PivotTable1").PivotFields("Supplier Code").Subtotals _
        = Array(False, False, False, False, False, False, False, False, False, False, False, False _
        )
    With s8.PivotTables("PivotTable1")
        .ColumnGrand = False
        .RowGrand = False
    End With
    s8.PivotTables("PivotTable1").RowAxisLayout xlTabularRow
    With s8.PivotTables("PivotTable1").PivotFields("Supplier Code")
        .Orientation = xlRowField
        .Position = 1
    End With
    With s8.PivotTables("PivotTable1").PivotFields("PCS Code")
        .Orientation = xlRowField
        .Position = 2
    End With
    s8.PivotTables("PivotTable1").AddDataField s8.PivotTables( _
        "PivotTable1").PivotFields("CorrectNetValue"), "Sum of CorrectNetValue", xlSum
    Columns("A:C").Copy
        Range("F1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    LastRow1 = s8.Cells(Rows.Count, "H").End(xlUp).Row + 1
    LastRow2 = s8.Cells(Rows.Count, "H").End(xlUp).Row
    s8.Range("F4:H" & LastRow2).Name = "DefaultPCS"
    Application.Goto Reference:="DefaultPCS"
    ActiveWorkbook.Worksheets("Supplier Default PCS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Supplier Default PCS").Sort.SortFields.Add Key:=Range("F4:F" & LastRow2) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Supplier Default PCS").Sort.SortFields.Add Key:=Range("G4:G" & LastRow2) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Supplier Default PCS").Sort
        .SetRange Range("F3:H" & LastRow2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    LastRow1 = s8.Cells(Rows.Count, "F").End(xlUp).Row + 1
    LastRow2 = s8.Cells(Rows.Count, "F").End(xlUp).Row
    s8.Range("F4:G" & LastRow2).Name = "SupplierPCS"
    LastRow1 = s1.Cells(Rows.Count, "AI").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AI2:AI" & LastRow2).Formula = "=VLOOKUP(AD2,SupplierPCS,2,FALSE)"


'Resizes Columns
    s1.Columns("A:AZ").AutoFit


'Copy and paste values for all Columns EXCEPT CorrectNetValue Only
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("A2:Y" & LastRow2).Copy
    s1.Range("A2:Y" & LastRow2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("AA2:AZ" & LastRow2).Copy
    s1.Range("AA2:AZ" & LastRow2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


'Save a copy of File as "ForEx WIP" with "ForEx" formula included in case of a WhatIf analysis being needed at a later date


    saveFileName = Environ("UserProfile") & "\Desktop\EGBCIS13 " & UCase$(Format(WorksheetFunction.EoMonth(Now, -1), "mmm yyyy")) & " GL FOREX WIP.xlsx"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=saveFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


'Copy and paste values for CorrectNetValue Only
    LastRow1 = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastRow2 = s1.Cells(Rows.Count, "A").End(xlUp).Row
    s1.Range("Z2:Z" & LastRow2).Copy
    s1.Range("Z2:Z" & LastRow2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


'Removes name ranges
Dim xName As Name
For Each xName In Application.ActiveWorkbook.Names
    xName.Delete
Next


'Removes unwanted Worksheets
    Application.DisplayAlerts = False
    Sheets(Array("Instructions", "ForEx", "Template", "Supplier Default PCS", "Ownership Update", "BUM", "PCS")).Delete


'Save File
    saveFileName = Environ("UserProfile") & "\Desktop\EGBCIS13 " & UCase$(Format(WorksheetFunction.EoMonth(Now, -1), "mmm yyyy")) & " GL WIP.xlsx"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=saveFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    s1.Range("A1").Select


End Sub

Many thanks,
Gareth
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top