Loop through VBA collection

[Rymare]

I have an excel with a list of paths:

This list can change length--sometimes there are 100 .xlsx files, sometimes 4, etc. But always xlsx and always in the same sheet in my workbook (Project Specialist Compile, sheet ghgh). The paths are not fixed, they constantly change so though the list appears to share certain patterns, that will not always be the case.

I want to be able to open these excels, take the data from the first sheet in each excel, and merge it into one sheet in my Project Specialist Compile workbook (sheet is called Addresses). Then have the code move to the next path in the collection open that one, copy paste, etc. The excels do not have a fixed range to paste. They all have a header, but can have 1 row with data or 500 rows with data, so I can't set a fixed range to copy there either. They look like this:

I need the code to count what cells have data (paths), put them into the collection, and then loop them ('for each path in collection' syntax). I want to end up with this:

I would like to NOT have each excel pop up, open, copy, paste then close because that could take forever if there's a long list of paths.

The code below always stops at

Set dirObj = mergeObj.GetFolder("vElement.Value")

and shows:

Option ExplicitSub openingandcopying()


Dim bookList As Workbook
Dim wsp As Worksheet: Set wsp = Sheets("ghgh")
Dim mergeObj As Object
Dim dirObj As Object
Dim filesObj As Object
Dim everyObj As Object
Dim colMyCol As New Collection
Dim vElement As Variant
Dim rRange As Range
Dim rCell As Range
Dim lCount As Long




Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
Set rRange = wsp.Range("A1")
Set rRange = Range(rRange, rRange.End(xlDown))


For Each rCell In rRange
   colMyCol.Add rCell.Value
Next


For Each vElement In colMyCol
    Set dirObj = mergeObj.GetFolder("vElement.Value")
    Set filesObj = dirObj.Files
        For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
 
        Range("A2:X" & Range("A65536").End(xlUp).Row).copy
        ThisWorkbook.Sheets("Addresses").Activate


        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
        Application.CutCopyMode = False
        bookList.Close
        Next everyObj
Next vElement


End Sub

 

[shg]

Sub Rymare()
  Dim cell As Range

  With Worksheets("ghgh")
    For Each cell In .Range("A1", Cells(Rows.Count, "A").End(xlUp)).Cells
      If Len(Dir(cell.Value)) Then
        With Workbooks.Open(cell.Value)
          Range("A2:X" & Cells(Rows.Count, "A").End(xlUp).Row).Copy _
              ThisWorkbook.Worksheets("Addresses").Cells(Rows.Count, "A").End(xlUp)(2)
          .Close SaveChanges:=False
        End With
      Else
        MsgBox "File not found: " & cell.Value
      End If
    Next cell
  End With
End Sub

 

[Rymare]

Ok....but it still caused excel to crash? Is there a fix or a way to move more smoothly? So it doesn't crash?

 

[shg]

I have no way of know why Excel is crashing. What happens when you step through the code, where does it fall over?

 

[shg]

This

For Each cell In .Range("A1", Cells(Rows.Count, "A").End(xlUp)).Cells

should be

For Each cell In .Range("A1", [SIZE=6][COLOR="#FF0000"].[/COLOR][/SIZE]Cells([SIZE=6][COLOR="#FF0000"].[/COLOR][/SIZE]Rows.Count, "A").End(xlUp)).Cells

 

[Rymare]

Works like a charm! Thank you!

 

[shg]

You're welcome.