Inefficient coding

J

jtotman

New Member
Joined
Jul 6, 2018
Messages
9
Hi all,

I built a set of macros that is supposed to consolidate deposit information from four workbooks into one worksheet, and then build an index from four additional workbooks to pair customer names with deposit data. Unfortunately, this macro takes over an hour to complete, and I am unsure of how to make it an more efficient (I am self taught and still learning!). Any pointers on how to make this code more efficient would be greatly appreciated. When it is all said and done, there are over 200,000 lines of data being manipulated --> which may be the main cause for lag. I will post the code below. Thank you in advance!

Code: 
Sub GetDeposits()


Application.ScreenUpdating = False
Application.DisplayAlerts = False


Call ClearData
Call TTCdata
Call BOCdata
Call MBdata
Call VISTdata
Call BOCIndex
Call TTCIndex
Call VISTIndex
Call MBIndex
Call CustomerName




Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("Deposits").Activate
Cells.EntireColumn.AutoFit


Application.CalculateFullRebuild




End Sub


Option Explicit
Sub TTCdata()


Dim LastRowRange As Long
 Dim LastRowData As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsAccts As Worksheet


Set wsAccts = ThisWorkbook.Worksheets("Deposits")
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\TTC Dep.xlsx")
  
Workbooks("TTC Dep.xlsx").ActiveSheet.Range("A1:A2").EntireRow.Copy Workbooks("Deposits 360 for Loren.xlsm").Worksheets("Deposits").Range("A1:A2").EntireRow


  
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
        After:=.Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    
     LastRowData = wsAccts.Cells(wsAccts.Rows.Count, "A").End(xlUp).Row + 1


      .Range("A3", "AB" & LastRowRange).Copy wsAccts.Range("A" & LastRowData)
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub
Sub BOCdata()


Dim LastRowRange As Long
 Dim LastRowData As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsAccts As Worksheet


Set wsAccts = ThisWorkbook.Worksheets("Deposits")
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\BOC Dep.xlsx")
  
 
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
        After:=.Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    
     LastRowData = wsAccts.Cells(wsAccts.Rows.Count, "A").End(xlUp).Row + 1


      .Range("A3", "AB" & LastRowRange).Copy wsAccts.Range("A" & LastRowData)
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub
Sub MBdata()


Dim LastRowRange As Long
 Dim LastRowData As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsAccts As Worksheet


Set wsAccts = ThisWorkbook.Worksheets("Deposits")
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\MB Dep.xlsx")
  
 
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
        After:=.Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    
     LastRowData = wsAccts.Cells(wsAccts.Rows.Count, "A").End(xlUp).Row + 1


      .Range("A3", "AB" & LastRowRange).Copy wsAccts.Range("A" & LastRowData)
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub
Sub VISTdata()


Dim LastRowRange As Long
 Dim LastRowData As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsAccts As Worksheet


Set wsAccts = ThisWorkbook.Worksheets("Deposits")
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\VIST Dep.xlsx")
  
 
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
        After:=.Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    
     LastRowData = wsAccts.Cells(wsAccts.Rows.Count, "A").End(xlUp).Row + 1


      .Range("A3", "AB" & LastRowRange).Copy wsAccts.Range("A" & LastRowData)
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub


Sub BOCIndex()


 Dim LastRowRange As Long
 Dim LastRowIndex As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsIndex As Worksheet
Set wsIndex = ThisWorkbook.Worksheets("Index")


  Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\BOC Cust.xlsx")
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
     After:=.Range("A1"), _
     LookAt:=xlPart, _
     LookIn:=xlFormulas, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlPrevious, _
     MatchCase:=False).Row
    
     LastRowIndex = wsIndex.Cells(wsIndex.Rows.Count, "B").End(xlUp).Row + 1


      .Range("A4", "D" & LastRowRange).Copy
      wsIndex.Range("B" & LastRowIndex).PasteSpecial xlPasteValues
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub


Sub TTCIndex()


Dim LastRowRange As Long
 Dim LastRowIndex As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsIndex As Worksheet
Set wsIndex = ThisWorkbook.Worksheets("Index")


  Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\TTC Cust.xlsx")
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
     After:=.Range("A1"), _
     LookAt:=xlPart, _
     LookIn:=xlFormulas, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlPrevious, _
     MatchCase:=False).Row
    
     LastRowIndex = wsIndex.Cells(wsIndex.Rows.Count, "B").End(xlUp).Row + 1


      .Range("A4", "D" & LastRowRange).Copy
      wsIndex.Range("B" & LastRowIndex).PasteSpecial xlPasteValues
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub


Sub VISTIndex()


Dim LastRowRange As Long
 Dim LastRowIndex As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsIndex As Worksheet
Set wsIndex = ThisWorkbook.Worksheets("Index")


  Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\VIST Cust.xlsx")
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
     After:=.Range("A1"), _
     LookAt:=xlPart, _
     LookIn:=xlFormulas, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlPrevious, _
     MatchCase:=False).Row
    
     LastRowIndex = wsIndex.Cells(wsIndex.Rows.Count, "B").End(xlUp).Row + 1


      .Range("A4", "D" & LastRowRange).Copy
      wsIndex.Range("B" & LastRowIndex).PasteSpecial xlPasteValues
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub




Sub MBIndex()


Dim LastRowRange As Long
 Dim LastRowIndex As Long
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim wsIndex As Worksheet
Set wsIndex = ThisWorkbook.Worksheets("Index")


  Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\MB Cust.xlsx")
   For Each ws In wb.Worksheets
    With ws
     LastRowRange = .Cells.Find(What:="*", _
     After:=.Range("A1"), _
     LookAt:=xlPart, _
     LookIn:=xlFormulas, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlPrevious, _
     MatchCase:=False).Row
    
     LastRowIndex = wsIndex.Cells(wsIndex.Rows.Count, "B").End(xlUp).Row + 1


      .Range("A4", "D" & LastRowRange).Copy
      wsIndex.Range("B" & LastRowIndex).PasteSpecial xlPasteValues
    End With
   Next ws
   
wb.Close savechanges:=False


End Sub


Sub ClearData()


Windows("Deposits 360 for Loren.xlsm").Activate
Worksheets("Deposits").Range("A:AB").Clear
Worksheets("Index").Range("B:E").Clear


End Sub


Sub CustomerName()
 
Dim LastRowData As Long
LastRowData = Worksheets("Deposits").Range("A1").End(xlDown).Row
Dim OgNames As Long
OgNames = Worksheets("Deposits").Range("AC1").End(xlDown).Row


Worksheets("Deposits").Range("AC:AC").Clear


Worksheets("Deposits").Range("AC2").FormulaR1C1 = _
"=INDEX(Index!C[-25], MATCH(RC[-15], Index!C[-26], 0))"


Worksheets("Deposits").Range("AC2").AutoFill Destination:=Worksheets("Deposits").Range("AC2:AC" & LastRowData)


 
End Sub
 
Last edited by a moderator:

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
Hi jtotman

Try the below code which may not be any faster but it summarizes your long/repetitive code … How many sheets in each workbook ? What's taking too much time copying the data from the different workbooks or the index match formula at the end ?
​

Code: 
Sub Consolidate()
Application.ScreenUpdating = False
Dim Wb As Workbook, Ws As Worksheet, wsAccts As Worksheet, wsIndex As Worksheet, lRow As Long
Set wsAccts = ThisWorkbook.Worksheets("Deposits")
Set wsIndex = ThisWorkbook.Worksheets("Index")
For x = 1 To 8
    Select Case x
        Case 1: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\TTC Dep.xlsx")
        Case 2: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\BOC Dep.xlsx")
        Case 3: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\MB Dep.xlsx")
        Case 4: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\VIST Dep.xlsx")
    
        Case 5: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\BOC Cust.xlsx")
        Case 6: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\TTC Cust.xlsx")
        Case 7: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\VIST Cust.xlsx")
        Case 8: Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\MB Cust.xlsx")
    End Select
    
    If x = 1 Then Wb.ActiveSheet.Range("A1:A2").EntireRow.Copy Workbooks("Deposits 360 for Loren.xlsm").Worksheets("Deposits").Range("A1:A2").EntireRow
    
    If x < 5 Then
        lRow = wsAccts.Range("A" & Rows.Count).End(xlUp).Row + 1
        For Each Ws In Wb.Worksheets
            wsAccts.Range("A" & lRow) = Ws.Range("A3").CurrentRegion.Value2
        Next
    Else
        lRow = wsIndex.Range("B" & Rows.Count).End(xlUp).Row + 1
        For Each Ws In Wb.Worksheets
            wsIndex.Range("B" & lRow) = Ws.Range("A4").CurrentRegion.Value2
        Next
    End If
    Wb.Close SaveChanges:=False
Next x
lRow = wsAccts.Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Deposits")
    .Range("AC:AC").Clear
    .Range("AC2").FormulaR1C1 = "=INDEX(Index!C[-25], MATCH(RC[-15], Index!C[-26], 0))"
    .Range("AC2").AutoFill Destination:=Worksheets("Deposits").Range("AC2:AC" & lRow)
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
How can I create a code to calculate first day in the month taking bank holidays away?
Replies
7
Views
85
Eric Penfold
E
M
  • Question
Vba code to find and replace in excel closed workbooks.
Replies
1
Views
352
6StringJazzer
6StringJazzer
J
  • Solved
Emailing active WS as Excel attachment failing
Replies
5
Views
270
NoSparks
N
P
  • Question
VBA to import multilpe xml files
Replies
1
Views
51
PippaThePointer
P
G
  • Solved
Dir(FolderPath) - multiple file formats
Replies
1
Views
332
DanteAmor
DanteAmor

Forum statistics

Threads
1,215,064
Messages
6,122,939
Members
449,094
Latest member
teemeren

Share this page

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