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.
Many thanks,
Gareth
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