CODEWITHSUNDEEP
excelvba
Daiichi_kun
Daiichi_kun

Reputation: 27

Macro Program Very Slow

i need help. I have a program that extracts data from the workbooks listed in the listbox. The problem is the extraction takes time. Can you suggest a better solution? Thanks!

This is the code for extracting data:

Option Explicit
Sub Extract_Data()

Dim CurrentBook As Workbook
Dim WS, Sheet As Worksheet
Set WS = ThisWorkbook.Sheets("ALL DATA")
Dim i, j, LRow1, LRow2 As Long
Dim RangeToCopy As Range
Dim pc As PivotCache

'VBA Code Timer
Dim dTime As Double
dTime = Timer

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With

    For i = 0 To ThisWorkbook.Sheets("MAIN").ListBox1.ListCount - 1
   
            Set CurrentBook = Workbooks.Open(ThisWorkbook.Sheets("MAIN").ListBox1.List(i))
    
           
                    LRow1 = WS.Range("C" & WS.Rows.Count).End(xlUp).Row
                    LRow2 = CurrentBook.ActiveSheet.Range("C" & 
       CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row
                       
                    Set RangeToCopy = CurrentBook.ActiveSheet.Range("D28:E" & LRow2 & ", 
         H28:H" & LRow2)
                         RangeToCopy.Copy
                    WS.Range("C" & LRow1 + 1).PasteSpecial 
         Paste:=xlPasteValuesAndNumberFormats
    
                       For j = 1 To LRow2 - 27
                            WS.Range("A" & LRow1 + j).Value2 = 
          CurrentBook.ActiveSheet.Range("B10")
                       Next


            
        Application.CutCopyMode = False
        CurrentBook.Close True
      
    Next i
    


  With Application
  .CutCopyMode = False
  .EnableEvents = True
  .Calculation = xlCalculationAutomatic
  .DisplayAlerts = True
  .ScreenUpdating = True
  End With

   Debug.Print "Time is: " & (Timer - dTime) * 1000
 End Sub

This is my program. I will click "Open File" to select workbooks This is my program. I will click "Open File" to select workbooks

The selected files will appear in the listbox. When I click extract data, The selected files will appear in the listbox. When I click extract data,

Data are extracted and pasted to Worksheet "ALL DATA" in columns A,C,D,E Data are extracted and pasted to Worksheet "ALL DATA" in columns A,C,D,E

Upvotes: 0

Views: 101

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, try the next code:

Option Explicit

Sub Extract_Data()
    Dim CurrentBook As Workbook, WS As Worksheet, Sheet As Worksheet
    Set WS = ThisWorkbook.Sheets("ALL DATA")
    Dim i As Long, j As Long, LRow1 As Long, LRow2 As Long
    Dim arrCopy
    
    'VBA Code Timer
    Dim dTime As Double: dTime = Timer
       
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
     End With
   
    For i = 0 To ThisWorkbook.Sheets("MAIN").ListBox1.ListCount - 1
                Set CurrentBook = Workbooks.Open(ThisWorkbook.Sheets("MAIN").ListBox1.List(i))
                LRow1 = WS.Range("C" & WS.Rows.Count).End(xlUp).Row
                LRow2 = CurrentBook.ActiveSheet.Range("C" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row
                    
               arrCopy = CurrentBook.ActiveSheet.Range("D28:E" & LRow2).Value2
               With WS.Range("C" & LRow1 + 1).Resize(UBound(arrCopy), UBound(arrCopy, 2))
                    .Value = arrCopy
                    .NumberFormat = CurrentBook.ActiveSheet.Range("D28").NumberFormat
                End With
                arrCopy = CurrentBook.ActiveSheet.Range("H28:H" & LRow2).Value2
               With WS.Range("E" & LRow1 + 1).Resize(UBound(arrCopy), UBound(arrCopy, 2))
                    .Value = arrCopy
                    .NumberFormat = CurrentBook.ActiveSheet.Range("D28").NumberFormat
                End With
                           
                WS.Range("A" & LRow1 + 1 & ":A" & LRow2 - 27).Value2 = CurrentBook.ActiveSheet.Range("B10").Value2
                
                Application.CutCopyMode = False
                CurrentBook.Close False
    Next i
    
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
 
    Debug.Print "Time is: " & (Timer - dTime) * 1000
    MsgBox "Ready..."
End Sub

Upvotes: 3

Related Questions