"Simple" VBA code running long...

[Brad Friedman]

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

 

[mumps]

I'm not sure how much time it would save but the highlighted lines of code can be replaced with:

.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:

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]

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:

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.

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]

I'm not sure how much time it would save but the highlighted lines of code can be replaced with:

.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]

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:

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]

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.