Convert VBA Application.Filesearch Copy/Paste

[Mtaylorlc]

I am trying to update some old code I used years ago to work in a current process. The code below, for every source workbook in the same folder, will open, copy a specific range, paste that range in a summary/master workbook, and close the source document. It loops through this process for all excel documents in the folder, excluding the summary/master.

One change in how this is being used that may or may not be relevant... The source documents are all stored in a MS Teams folder...

Private Sub cmdUpdate_Click()
Dim FS, i
Dim PlaceRow As Long
Dim OpenedName As String
Dim DoNotReopenActiveWB_Name As String
Dim DataBook As String

Sheet1.Range("A2:AF1000").ClearContents
Sheet1.Range("BA1:BA1000").ClearContents
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
DoNotReopenActiveWB_Name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
DataBook = ActiveWorkbook.Name
PlaceRow = 1
Debug.Print DoNotReopenActiveWB_Name
Set FS = Application.FileSearch
With FS
    .LookIn = ActiveWorkbook.Path
    .Filename = "*.xlsx"
    If .Execute Then
        For i = 1 To .FoundFiles.Count
            If .FoundFiles(i) <> DoNotReopenActiveWB_Name Then
                PlaceRow = PlaceRow + 1
                Workbooks.Open .FoundFiles(i)
                OpenedName = ActiveWorkbook.Name
                Workbooks(DataBook).Sheets("Level 1") _
                    .Range("A" & PlaceRow & ":AI" & PlaceRow).Value = _
                Workbooks(OpenedName).Sheets("Level 1") _
                    .Range("A114:AI114").Value
                Workbooks(DataBook).Sheets("Table1") _
                    .Range("BA" & PlaceRow).Value = .FoundFiles(i)
                Workbooks(OpenedName).Close savechanges:=False
            End If
        Next i
    End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Try this

Private Sub cmdUpdate_Click()
  Dim wFiles As Variant, sPath As String, i As Long
  Dim wb1 As Workbook, wb2 As Workbook
  
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  Set wb1 = ThisWorkbook
  wb1.Sheets("Level 1").Range("A2:AI1000").ClearContents
  wb1.Sheets("Table1").Range("BA1:BA1000").ClearContents
  
  sPath = wb1.Path & "\"          '
  wFiles = Dir(sPath & "*.xlsx")  'all xlsx files
  i = 1                           'PlaceRow
  
  Do While wFiles <> ""
    If wFiles <> wb1.Name Then
      i = i + 1
      Set wb2 = Workbooks.Open(sPath & wFiles)
      wb1.Sheets("Level 1").Range("A" & i & ":AI" & i).Value = wb2.Sheets("Level 1").Range("A114:AI114").Value
      wb1.Sheets("Table1").Range("BA" & i).Value = wFiles
      wb2.Close savechanges:=False
    End If
    wFiles = Dir()
  Loop
  
  Application.EnableEvents = True
End Sub

 

[Mtaylorlc]

Thank you Dante! ?

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.