• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Can this code be further condensed

S

Shah

New Member
Hi All,

I have written a code and was wondering if this can be further reduce. All is working fine.
Thank you in advance.
Shah.

Code: 
Option Explicit
Sub Final()
Dim var As Variant ' Sheet Name
Dim i As Integer
Dim j As Integer
Dim k
Dim ToSht
Dim sh As Worksheet
Dim wb As Workbook
Dim wsCash As Worksheet
Dim wsData As Worksheet
Dim wsFX As Worksheet
Dim wsProjected As Worksheet
Dim wsCustody As Worksheet
Dim wsReport As Worksheet
Dim Pass1 As Variant
Dim FrmSht As Worksheet
Dim lRow As Long
Dim lr As Long
Dim FieldFilters1 As Variant
Dim FieldFilters2 As Variant
Dim TempCols
Dim DataCols
Dim ThisFile As Variant

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set sh = Sheet2  ' Macro worksheet
Set wb = Workbooks.Open(sh.[E19])  ' workbook
Set wsCash = Worksheets(sh.[C19].Value)  '  Template
Set wsData = Worksheets(sh.[C20].Value)  '  Template
Set wsFX = Worksheets(sh.[C21].Value)  '  Template
Set wsProjected = Worksheets(sh.[C22].Value) ' Template
Set wsCustody = Worksheets(sh.[C23].Value)  '  Template
Set wsReport = Worksheets(sh.[C24].Value)  ' Template

  var = sh.Range("C2", sh.Range("C" & Rows.Count).End(xlUp))
  Pass1 = sh.[A3].Value 'Password for Portected file

'Copy data 
k = Array(2, 3, 4, 5, 6) 'Data file name from Macro Spreadsheet
ToSht = Array(wsCash, wsCash, wsData, wsFX, wsCustody) 'Template Tab Names
DataCols = Array("A6:J", "A6:J", "A7:J", "A6:D", "A6:D") 'Data file ranges copied
  For i = LBound(k) To UBound(k) 'Loop through files and copy data
  Set wb = Workbooks.Open(sh.Range("E" & k(i))) 'File Path & Name
  Set FrmSht = wb.Sheets(var(k(i) - 1, 1)) 'Data file Tab name
  lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  'Find the last row on DataSheet
  If FrmSht.Range("A6").Value <> "No Data for this report" Then
  FrmSht.Range(DataCols(i) & lRow).Copy ToSht(i).Range("A" & Rows.Count).End(xlUp)(2) 'Copy Columns as per DataCols
  End If
  wb.Close 'Close the workbook
  Next i
  
'Copy data 
j = 7 
Set wb = Workbooks.Open(sh.Range("E" & j))
Set FrmSht = wb.Sheets(var(j - 1, 1)) 
  TempCols = Array(2, 9, 10) 
  DataCols = Array(1, 9, 10)   
GetData1 FrmSht, wsCash, TempCols, DataCols, 6
wb.Close 

'Copy data
j = 9 
Set wb = Workbooks.Open(sh.Range("E" & j)) 
Set FrmSht = wb.Sheets(var(j - 1, 1)) 
  TempCols = Array(2, 9, 10) 
  DataCols = Array(13, 10, 9)   
GetData1 FrmSht, wsCash, TempCols, DataCols, 2
wb.Close 

'Copy data 
j = 10 
Set wb = Workbooks.Open(sh.Range("E" & j), Password:=Pass1) 
Set FrmSht = wb.Sheets(var(j - 1, 1)) 
  TempCols = Array(2, 9, 10) 
  DataCols = Array(4, 13, 6)   
GetData1 FrmSht, wsCash, TempCols, DataCols, 2
wb.Close 
  
'Fill in formula
lRow = wsCash.Range("B" & Rows.Count).End(xlUp).Row 
  wsCash.Range("A2:A" & lRow).SpecialCells(4) = "=RIGHT(RC[1],5)"
  
'Copy data 
j = 11 
Set wb = Workbooks.Open(sh.Range("E" & j)) 
  TempCols = Array("ILF0006007", "ILF0006007")
  DataCols = Array("GBP", "USD") 
  For i = LBound(TempCols) To UBound(TempCols) 
  Set FrmSht = wb.Sheets(DataCols(i)) 
  FrmSht.Cells(Rows.Count, 2).End(xlUp).Copy wsCash.Range("J" & Rows.Count).End(xlUp)(2)
  wsCash.Range("A" & Rows.Count).End(xlUp)(2) = TempCols(i) 
  wsCash.Range("I" & Rows.Count).End(xlUp)(2) = DataCols(i) 
  Next i
wb.Close 
  
lRow = wsCash.Range("A" & Rows.Count).End(xlUp).Row 
  wsCash.Range("C2:C" & lRow).SpecialCells(4) = "LQD FUNDS"
  
'Copy data 
j = 12 
On Error Resume Next
If Dir(sh.Range("E" & j)) <> "" Then 
  Set wb = Workbooks.Open(sh.Range("E" & j)) 
  Set FrmSht = wb.Sheets(var(j - 1, 1)) 
  lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  
Else
  Set wb = Workbooks.Open(sh.Range("E" & j + 1)) 
  Set FrmSht = wb.Sheets(var(j, 1)) 
  lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  
End If
  
  FieldFilters1 = Array("(GBP)", "(AUD)") 
  FieldFilters2 = Array("04F102471", "04F108841") 
  TempCols = Array("301371", "302724") 
  DataCols = Array("GBP", "AUD") 
For i = LBound(FieldFilters1) To UBound(FieldFilters1) 
  FrmSht.Range("A1:Q1" & lRow).AutoFilter Field:=9, Criteria1:=FieldFilters1(i), Operator:=xlFilterValues 
  FrmSht.Range("A1:Q1" & lRow).AutoFilter Field:=1, Criteria1:=FieldFilters2(i), Operator:=xlFilterValues 
  FrmSht.Range("C2:C" & lRow & ",K2:K" & lRow).Copy wsCash.Range("I" & Rows.Count).End(xlUp)(2) 
  wsCash.Range("A" & Rows.Count).End(xlUp)(2) = TempCols(i)  
  FrmSht.Range("E2:H" & lRow).Copy 'Copy Columns E to H
  wsData.Range("D" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True 
  wsData.Range("D" & Rows.Count).End(xlUp)(2).FormulaR1C1 = "=WORKDAY(R[-1]C,1)"
  FrmSht.Range("L2:P" & lRow).Copy 
  wsData.Range("J" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True 
  lr = wsData.Range("J" & Rows.Count).End(xlUp).Row 'Find the last row on DataSheet
  wsData.Range("A2:A" & lr).SpecialCells(4) = TempCols(i) 'Fill column A 
  wsData.Range("I2:I" & lr).SpecialCells(4) = DataCols(i)  'Fill column I 
  FrmSht.Range("A1:Q1" & lRow).AutoFilter Field:=9, Criteria1:="XXX" 'Filter 
  FrmSht.Range("C2:C" & lRow).SpecialCells(12).Copy
  wsReport.Range("J23").PasteSpecial Paste:=xlPasteValues 'Column J will have value from Column C Data file
  FrmSht.Range("K2:K" & lRow).SpecialCells(12).Copy
  wsReport.Range("K23").PasteSpecial Paste:=xlPasteValues 'Column J will have value from Column K Data file
Next i
FrmSht.ShowAllData  'clears filters
wb.Close 'Close the workbook

lRow = wsCash.Range("A" & Rows.Count).End(xlUp).Row 'Find the last row on DataSheet
  wsCash.Range("D2:D" & lRow) = wsCash.[E2].Value  'Column D populated with same data as Column E
  wsCash.Range("K2:K" & lRow) = "=IF(RC[-1]="""",0,RC[-1]/VLOOKUP(RC[-2],'FX Rates'!C[-9]:C[-8],2,0))" 'V-lookup 
  wsCash.Range("L2:L" & lRow) = "=IFERROR(LOOKUP(2,1/($P$2:$P$80=A2)/($Q$2:$Q$80=I2),($R$2:$R$80)),VLOOKUP(A2,$P$2:$R$80,3,FALSE))" 'V-lookup
  wsCash.Range("A2:J" & lRow).Copy wsData.Range("A" & Rows.Count).End(xlUp)(2) 'Copy data from Template "Cash" tab to "Data" tab
  
lRow = wsData.Range("A" & Rows.Count).End(xlUp).Row 'Find the last row on DataSheet
  wsData.Range("K2:K" & lRow) = "=IF(RC[-1]="""",0,RC[-1]/VLOOKUP(RC[-2],'FX Rates'!C[-9]:C[-8],2,0))" 'V-lookup 
  wsData.Range("L2:L" & lRow) = "=IFERROR(LOOKUP(2,1/($P$2:$P$80=A2)/($Q$2:$Q$80=I2),($R$2:$R$80)),VLOOKUP(A2,$P$2:$R$80,3,FALSE))" 'V-lookup 
  
'---------------------------------------------------------------------------------------------------
  
'Copy data 
j = 15 
Set wb = Workbooks.Open(sh.Range("E" & j)) 'File Path & Name
Set FrmSht = wb.Sheets(var(j - 1, 1)) 'Data file Tab name
lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  'Find the last row on DataSheet
  FieldFilters1 = Array("GBP", "USD", "EUR", "ZAR", "JPY", "AUD", "AUD") ' Autofilter categories
  FieldFilters2 = Array("*", "*", "*", "*", "*", "23156", "BAG64")  ' Autofilter categories
  TempCols = Array(2, 6, 10, 14, 18, 22, 26) 'Template Column numbers
  
  For i = LBound(TempCols) To UBound(TempCols) ' Loop on Column numbers in array to return data
  FrmSht.Range("A5:M" & lRow).AutoFilter Field:=2, Criteria1:=FieldFilters1(i), Operator:=xlFilterValues  ' Autofilter on a Column based on FieldFilters1
  FrmSht.Range("A5:M" & lRow).AutoFilter Field:=1, Criteria1:=FieldFilters2(i), Operator:=xlFilterValues  ' Autofilter on a Column based on FieldFilters1
  On Error Resume Next
  FrmSht.Range("C6:D" & lRow).SpecialCells(12).Copy wsProjected.Cells(12, TempCols(i))
  Next i
wb.Close 'Close the workbook
  
'Copy data 
j = 16 
Set wb = Workbooks.Open(sh.Range("E" & j)) 'File Path & Name
Set FrmSht = wb.Sheets(var(j - 1, 1)) 'Data file Tab name
lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  'Find the last row on DataSheet
  FieldFilters1 = Array("GB", "US") ' Autofilter categories
  TempCols = Array(1, 5) 'Template column numbers
  For i = LBound(TempCols) To UBound(TempCols) 'Loop to get data
  FrmSht.Range("A5:F" & lRow).AutoFilter Field:=6, Criteria1:=FieldFilters1(i), Operator:=xlFilterValues  ' Autofilter on a Column based on FieldFilters1
  FrmSht.Range("B6:D" & lRow).SpecialCells(12).Copy
  wsProjected.Cells(26, TempCols(i)).PasteSpecial Paste:=xlPasteValues 'Copy data from columns B to D
  Next i
wb.Close 'Close the workbook
  
'---------------------------------------------------------------------------------------------------

'Copy data
j = 17 
Set wb = Workbooks.Open(sh.Range("E" & j)) 'File Path & Name
Set FrmSht = wb.Sheets(var(j - 1, 1)) 'Data file Tab name
lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row 'Find the last row on DataSheet
  If FrmSht.Range("H" & lRow) = "Y" Then
  wsReport.Range("J21").Value = FrmSht.Range("AI" & lRow).Value  'Column J will have value from Column AI Data file
  End If
  If FrmSht.Range("H" & lRow) = "Y" And FrmSht.Range("AE" & lRow) < "0" Then
  wsProjected.Range("B12").Value = FrmSht.Range("AE" & lRow).Value  'Column B will have value from Column AE Data file
  End If
  wsProjected.Range("A12").Value = "XXXX"
  wsProjected.Range("C12").Value = Date
wb.Close 'Close the workbook

'Refresh data and save file
Workbooks("Daily Cash Forecasting").RefreshAll
  
Application.DisplayAlerts = True
Application.ScreenUpdating = True 
  
End Sub

Sub GetData1(FrmSht, ToSht, TempCols, DataCols, rngStr)
Dim lRow As Long
Dim i As Long

lRow = FrmSht.Range("A" & Rows.Count).End(xlUp).Row  ' Find the last row on DataSheet

For i = LBound(DataCols) To UBound(DataCols)
  FrmSht.Range(Cells(rngStr, DataCols(i)), FrmSht.Cells(lRow, DataCols(i))).Copy ToSht.Cells(Rows.Count, TempCols(i)).End(xlUp)(2)
Next i

End Sub
 
Shah

I hope by "condensed" or "reduce" you don't equate that with efficiency or performance

One of the biggest myths about VBA is that it is slow
In fact the opposite is true, VBA is, to quote Daniel Ferry, "blindingly fast"
It is the poor coding practices that make it inefficient

You have many sections that extract data from a worksheet, cell by cell, and this is normally done more efficiently by retrieving the whole range into an array and then extract the values from the array. More code but oh so much faster.

I have only scanned briefly through your code, but retrieving the whole data block and processing it in VBA may be the way to go

If you want help making the code run faster, I'd suggest uploading a sample file and explaining what the code does, not line by line, but generically.
eg: I load this file, filter by these x values and save the data to a new file
 
Thank you Hui, I meant to reduce the size of the code. There are 13 spreadsheet where the data is picked up and pasted to a template on 5 different tabs.
The whole routine takes about 13 seconds to run (so it is fast :)). I was hoping to get some pointers to write the code better so it will be easier if any further changes to be made in future.
I had the comments in the code but it exceeded the 10,000 character limit for the message so had to take out most of the comments which talk about each line of code and what it is doing.

Hui said:
You have many sections that extract data from a worksheet, cell by cell, and this is normally done more efficiently by retrieving the whole range into an array and then extract the values from the array. More code but oh so much faster.

I have only scanned briefly through your code, but retrieving the whole data block and processing it in VBA may be the way to go
Click to expand...
I have no idea how to do the above! any pointers please?

Thanks,
Shah
 
You must log in or register to reply here.
Back
Top