0

I looked everywhere and cannot find a fitting solution.

In my source workbook I have a range in sheet "Basics" which contains several filenames.

For example Range A1:A25

But not every cell in this range will contain a filename. Some will be empty.

I need a macro that opens all the listed files in range A1:A25, then copies Range A1:K500 from sheet1 in these files and then pastes this data to my source workbook into several sheets.

The several sheets in my source workbook are named 1, 2, 3, 4, 5 etc.

So the macro should open the first file listed in range A1:A25 and copy the data from Range A1:K500 from sheet1 from this workbook to sheet "1" (Range A1:K500) in my sourceworkbook. Then open second file + same task and paste to sheet "2" in source workbook and so on..

Thank you and best regards, M

user15328429
  • 1
  • 1
    Stackoverflow is not a place where you can ask people to do the work for you. Please check how to ask here https://stackoverflow.com/help/how-to-ask – Ricardo Diaz Mar 04 '21 at 10:12

1 Answers1

0

Ok here is what I have so far:

Sub LoopAllExcelFilesInFolder()


Dim wb As Workbook
Dim wb2 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
 Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
 Do While myFile <> ""
  'Set variable equal to opened workbook
  Set wb = Workbooks.Open(FileName:=myPath & myFile)
  Set wb2 = ThisWorkbook

'Ensure Workbook has opened before moving on to next line of code
  DoEvents

'Change First Worksheet's Background Fill Blue
  wb.Worksheets(1).Range("A1:W500").Copy

---> Here is the the point where it needs to paste the copied data into sheet 1 of my workbook ---> After that the next external workbook is opened and the copied data will be pasted to sheet 2 of my workbook etc.

'Save and Close Workbook
  wb.Close SaveChanges:=True
  
'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True

End Sub
user15328429
  • 1