'The while loop sometimes is infinite
Sub Copy_Worksheets_Columns_Rows_to_ALL_D2()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'Task: Copy worksheets, columns and rows to ALL (D2)
Dim sourceSheet1 As Worksheet
Dim sourceSheet2 As Worksheet
Dim sourceSheet3 As Worksheet
Dim sourceColumn As Range, targetColumn As Range
Dim sourceRow As Range, targetRow As Range
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim folder As String, filename As String
Dim destinationWorkbook As Workbook
Dim myPath As String
Dim ALL_File As String
Dim ALL_Extension As String
'Optimize Macro Speed
Application.Calculation = xlCalculationManual
myPath = ActiveWorkbook.Path
If Right(myPath, 1) <> "\" Then myPath = myPath + "\"
SampleFileExtension = "sample.xlsx"
Set sourceWorkbook = Workbooks.Open(myPath & SampleFileExtension, Local:=True)
'Worksheet in source workbook to be copied as a new sheet
Set sourceSheet1 = sourceWorkbook.Worksheets(1)
Set sourceSheet2 = sourceWorkbook.Worksheets(2)
Set sourceSheet3 = sourceWorkbook.Worksheets(3)
Set sourceColumn = sourceWorkbook.Worksheets(4).Range("T:AD")
Set sourceRow = sourceWorkbook.Worksheets(4).Range("1026:1038")
fnd = "[" & sourceWorkbook.Name & "]"
rplc = ""
'ALL Target File Extension (must include wildcard "*")
ALL_Extension = "*.2.*.ALL.xlsx"
'ALL Target Path with Ending Extention
ALL_File = Dir(myPath & ALL_Extension)
Do While ALL_File <> ""
Set destinationWorkbook = Workbooks.Open(filename:=myPath & ALL_File, Local:=True)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
sourceSheet3.Copy before:=destinationWorkbook.Sheets(1)
sourceSheet2.Copy before:=destinationWorkbook.Sheets(1)
sourceSheet1.Copy before:=destinationWorkbook.Sheets(1)
Set targetColumn = ActiveWorkbook.Worksheets(4).Range("T:AD")
sourceColumn.Copy Destination:=targetColumn
Set targetRow = ActiveWorkbook.Worksheets(4).Range("1026:1038")
sourceRow.Copy Destination:=targetRow
'Perform the Find/Replace All
Sheets(4).Range("A1:AD1038").Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
destinationWorkbook.Close True
Exit Do
'Get next matching file
ALL_File = Dir()
Loop
sourceWorkbook.Close False
'Message Box when tasks are completed
'MsgBox "Copy D2 worksheets, columns and rows to ALL (Task 5) Complete!"
End Sub
Solution 1:[1]
When you modify files in a loop that is based on Dir you may get into this situation. Dir is great when you don't modify the files in the folder you are iterating over, but if you do make modifications, it is risky.
A pragmatic solution is to first collect the files you want to process, and then loop over that collection:
Dim ALL_File As Variant ' Make sure it is Variant now
Dim c As Collection
Set c = New Collection
' Other initialisations ...
' ...
' ...
ALL_File = Dir(myPath & ALL_Extension)
' Collect file names
Do While ALL_File <> ""
c.Add ALL_File
ALL_File = Dir
Loop
' Iterate over the collection of file names
For Each ALL_File In c
Set destinationWorkbook = Workbooks.Open(filename:=myPath & ALL_File, Local:=True)
' ... process the open workbook ...
' ...
destinationWorkbook.Close True
Next
In summary:
- Modify the declaration of
ALL_Fileso it is aVariant, not aString - Add the declaration of
cand its initialisation. - Add the new, smaller loop that uses
Dirto populate theccollection. - Turn your existing loop from a
Do While...Loopinto aFor Each...Nextloop (as shown above) - Remove the last statement from that loop, which did the call to
Dir
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 |
