"Simple" VBA code running long...

Brad Friedman

New Member
Joined
Aug 21, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
I have code that opens an excel file, goes sheet by sheet row by row looking to see if cell Cx is not blank (x is the row #). If it is not blank, it copies some of the cells on that row to another open Workbook. It performs this task for every file in a folder. The problem is not the number of files, or the number of sheets or the number of rows. The problem is that each record written takes literally 4 seconds to write out a 5 cell record (2 assigned values, 3 copied from the worksheet in question). When you have 600 rows that need to get written out, thats like 41 minutes (40 minutes to write the records, and no time to traverse the 3000+ records that are not written out...

I have done the obvious stuff like turn off screen updating and auto calculation - instead of copy/paste (.Range assignment), I have tried Cell and offset commands too - they are actually worse in performance. The time is definitely in the "copy" with the Range assignment area - everything else runs "normally"...

I highlighted the slow mover...Any help is appreciated! I am sure there has to be something faster...

'Optimize Macro Speed

Application.StatusBar = ""
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
'Removed code irrelevant here


'Loop through each Excel file in folder

Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)


Application.ScreenUpdating = True
Application.StatusBar = "Working on " & myFile & " Be Patient - this is a slow process"
Application.ScreenUpdating = False

' Remove old comments from this person

wb.Sheets("Instructions").Select
lbtext = wb.Sheets("Instructions").Range("D1")
i = 8
ThisWorkbook.Sheets("Comments").UsedRange ''Refresh UsedRange
Do While i <= ThisWorkbook.Sheets("Comments").UsedRange.Rows(ThisWorkbook.Sheets("Comments").UsedRange.Rows.Count).Row
If (ThisWorkbook.Sheets("Comments").Range("A" & i).Value = lbtext) Then
ThisWorkbook.Sheets("Comments").Rows(i).Delete
Else
i = i + 1
End If
ThisWorkbook.Sheets("Comments").UsedRange 'Refresh UsedRange
Loop

lbtext = ""
For i = 1 To 12
codenameshname = "Ven_" & i
Set shname = GetSheetWithCodename(codenameshname, wb, lbtext)
For j = 12 To 260
If (shname.Range("C" & j) <> "") Then
With ThisWorkbook.Sheets("Comments")
.UsedRange 'Refresh UsedRange
lastrow = .UsedRange.Rows.Count + 2
.Range("A" & lastrow) = lbtext
.Range("B" & lastrow) = Date
.Range("C" & lastrow) = shname.Range("B11").Value
.Range("D" & lastrow) = shname.Range("A" & j).Value
.Range("E" & lastrow) = shname.Range("C" & j).Value

End With
End If
Next j
Next i

'Save and Close Workbook
wb.Close SaveChanges:=True

'Get next file name
myFile = Dir
Loop

'Message Box when tasks are completed

MsgBox "Comments Copied!"

End If
 

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,007
I'm not sure how much time it would save but the highlighted lines of code can be replaced with:
VBA Code:
.Range("A" & lastrow).Resize(, 5).Value = Array(lbtext, Date, shname.Range("B11").Value, shname.Range("B11").Value, shname.Range("C" & j).Value)
You also have code such as:
VBA Code:
wb.Sheets("Instructions").Select
You most often don't have to select a sheet to perform some action on it. I don't know if I can offer a solution but it would be easier to help if you could upload a copy of your destination file and a copy of at least one source file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
For j = 12 To 260

Your code has that line, it means you check from line 12 to 260.
If you have more than 260 lines in the sheets, then this line should be updated in the macro:
Rich (BB code):
ReDim a(1 To nFiles * 12 * 260, 1 To 5)
If you do not know the number of rows, then you could comment on the maximum number of rows that one of the sheets of the books could have.

Try the following code, it stores all the information of the cells, of all the sheets and all the books in a variable in memory; at the end it unloads the variable in the "Comments" sheet.

VBA Code:
Sub Optimize()
  Dim wb As Workbook, sh As Worksheet, shName As Worksheet
  Dim myPath As String, myFile As Variant, lbtext As String, bStr As String
  Dim i As Long, j As Long, k As Long, nFiles As Long, n As Long
  Dim a As Variant, b() As Variant
 
  Application.ScreenUpdating = False
  Application.StatusBar = ""
 
  Set sh = ThisWorkbook.Sheets("Comments")
  myPath = "C:\trabajo\books\"
  myFile = Dir(myPath & "*.xls*")
  Do While myFile <> ""
    nFiles = nFiles + 1
    myFile = Dir()
  Loop
  ReDim a(1 To nFiles * 12 * 260, 1 To 5)
 
  myFile = Dir(myPath & "*.xls*")
  Do While myFile <> ""
    n = n + 1
    Application.StatusBar = "Processing file : " & n & " of " & nFiles
    Set wb = Workbooks.Open(myPath & myFile)
   
    ' Remove old comments from this person
    lbtext = wb.Sheets("Instructions").Range("D1").Value
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
    sh.Range("A8", sh.Range("A" & Rows.Count).End(3)).AutoFilter 1, lbtext
    sh.AutoFilter.Range.Offset(1).EntireRow.Delete
   
    For i = 1 To 12
      Set shName = GetSheetWithCodename("Ven_" & i, wb, lbtext)
      Erase b
      b = shName.Range("A12", shName.Range("C" & Rows.Count).End(3)).Value2
      bStr = shName.Range("B11")
      For j = 1 To UBound(b)
        If b(j, 3) <> "" Then
          k = k + 1
          a(k, 1) = lbtext
          a(k, 2) = Date
          a(k, 3) = bStr
          a(k, 4) = b(j, 1)
          a(k, 5) = b(j, 3)
        End If
      Next j
    Next i
   
    wb.Close False
    myFile = Dir()
  Loop
 
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  sh.Range("A" & Rows.Count).End(3)(2).Resize(k, 5).Value = a
  Application.StatusBar = ""
  Application.ScreenUpdating = True
 
  MsgBox "Comments Copied!"
End Sub
 

Brad Friedman

New Member
Joined
Aug 21, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
I'm not sure how much time it would save but the highlighted lines of code can be replaced with:
VBA Code:
.Range("A" & lastrow).Resize(, 5).Value = Array(lbtext, Date, shname.Range("B11").Value, shname.Range("B11").Value, shname.Range("C" & j).Value)

Thanks for the array callout - went from 40 minutes to 1 1/2 minutes (which is very acceptable). I am happy with that performance.
 

Brad Friedman

New Member
Joined
Aug 21, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Your code has that line, it means you check from line 12 to 260.
If you have more than 260 lines in the sheets, then this line should be updated in the macro:
Rich (BB code):
ReDim a(1 To nFiles * 12 * 260, 1 To 5)
If you do not know the number of rows, then you could comment on the maximum number of rows that one of the sheets of the books could have.

Try the following code, it stores all the information of the cells, of all the sheets and all the books in a variable in memory; at the end it unloads the variable in the "Comments" sheet.

Thanks so much - now that I got the performance to an acceptable level - onto you solution as well. I think the in memory solution will work in other areas as well. This "package" has a lot more tentacles to it.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,007
You are very welcome. :) I think that you could most likely speed things up even further if you followed Dante's suggestion of putting your data into an array.
 

Watch MrExcel Video

Forum statistics

Threads
1,119,228
Messages
5,576,856
Members
412,750
Latest member
sammurraybooks
Top