VBA to Loop Through Excel Templates, Copy Specific Cells, and Paste in Master File

[nicktayl]

I have about 125 files that are all identical in format, but they contain project information I would like to copy and paste in a master file. There are only certain cells I want to copy. When pasting the data to the master file, I would like each file to have it's own row. I had the project halfway done when the code mysteriously deleted itself when I ran it. I have no idea what happened. I think it could have been laid out better, so I found a new template for a loop that will make it easier for me to add onto.

I'm curious where in the code I should enter my destination workbook. Also, in the loop, I would presume that in the DoEvents section I would enter the tasks I would like to have performed? I'm also curious the best way to setup a loop where there isn't one adjacent range that I'm copying. Do I have to copy, paste, copy, paste, copy, paste, or is there a way to do that with variables?

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com


Dim wb 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)
    
    '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:Z1").Interior.Color = RGB(51, 98, 174)
    
    '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

 

[alansidman]

To copy not adjacent ranges you can use the Application.Union functionality. Look at this link for a clear understanding A Better Union For VBA

 

[nicktayl]

Thank you alansidman,

I actually found a separate, simpler sub (1) that loops through files, and another (2) which copies non-contiguous cells pasting them in separate columns. I'm surprised there isn't code out there already that combines the two processes. It could be useful for so many scenarios.

When I try to customize the set pasteRange in (2) I get a runtime 9 error message. Once I get this working I will paste the code into the loop portion of (1). I will also add a variable for the row I'm pasting to in zmasterfile.xlsm that incrementally increases each time a paste is processed. Any ideas on the best way to do this and how to fix the error message? zmaster.xlsm and the templates are in the same folder.

(1)

 Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Users\ntaylor\Desktop\ROI"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
    If MyFile = "zmaster.xlsm" Then
    Exit Sub
    End If
    
    Workbooks.Open (Filepath & MyFile)
    
    
    Range("A2:D2").Copy
    ActiveWorkbook.Close
    
    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
    
    MyFile = Dir
Loop
End Sub

(2)

 Sub test()'declare the variables
Dim copyRange As Range, cel As Range, pasteRange As Range, erow As Long, ecolumn As Long
'we use the set keyword to create a new object
Set copyRange = ThisWorkbook.Sheets("Sheet1").Range("A2, B4, D5, E1, F3")
Set pasteRange = Workbooks("zmaster.xlsm").Sheets("Sheet2").Range("A1")
'start a looping process to copy and paste non-adjacent cells
For Each cel In copyRange
cel.Copy
ecolumn = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column


pasteRange.Range(cel.Address).PasteSpecial xlPasteValues


Next
Application.CutCopyMode = False
End Sub