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

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
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

P
  • Solved
Need help with VBA code prompting Compile error: Next without For
2
Replies
15
Views
497
Pi_Lover
P
G
  • Solved
Combine input box (multiple criteria)
Replies
4
Views
149
gomes123
G
E
  • Solved
This Code fills in below current month.
Replies
2
Views
196
Eric Penfold
E
H
  • Solved
Splitting Data into Workbooks - EDIT HELP
Replies
1
Views
291
horrellbt01
H
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
189
sijpie
sijpie

Forum statistics

Threads
1,224,814
Messages
6,181,128
Members
453,021
Latest member
Justyna P

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