Copy from multiple workbooks to a single one incrementally

[mariolj]

Hello all,

I have a challenge with copying a column from multiple workbooks and pasting into a single one. I have 20 workbooks and need to copy one column from each book and paste it into a new workbook in the same column. So, I want to have incremental copy paste. I am new to VBA and with the help of google I was able to write the following code:
I would appreciate your help

Option Explicit


Sub LoopFiles()


Dim wb As Workbook
Dim folder As String
Dim file As String
Dim extension As String
Dim FldrPicker As FileDialog




Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


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


extension = "*.csv"


file = Dir(folder & extension)




Do While file <> "" 


Set wb = Workbooks.Open(fileName:=myPath & myFile)
    
DoEvents
          
wb.Worksheets(1).Range("W1:w10").Copy


Application.thisWorkbook.Sheets("sheet1").Range("A1").PasteSpecial
    
'Save and Close Workbook
    
wb.Close savechanges:=False
    
DoEvents


'Get next file name
myFile = Dir

[B]     >>>>>>HERE I need to say close the copied book and find the latest cell in the new book [/B][B]do[/B][B] the same for the next books but now Range("A-the last row).PasteSpecial[/B]:confused:

Loop








End Sub

 

[Fluff]

Hi & welcome to MrExcel.
Try this

Sub LoopFiles()

   Dim wb As Workbook
   Dim folder As String
   Dim file As String
   Dim extension As String
   Dim FldrPicker As FileDialog
   
   Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
   With FldrPicker
      .title = "Select A Target Folder"
      .AllowMultiSelect = False
      If .Show <> -1 Then GoTo NextCode
      folder = .SelectedItems(1) & ""
   End With
   
   extension = "*.csv"
   file = Dir(folder & extension)
   Do While file <> ""
      Set wb = Workbooks.Open(FileName:=MyPath & MyFile)
      DoEvents
      wb.Worksheets(1).Range("W1:w10").Copy
      With Application.ThisWorkbook.Sheets("sheet1")
         .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial
      End With
      'Close Workbook
      wb.Close savechanges:=False
      DoEvents
      'Get next file name
      MyFile = Dir
   Loop
End Sub

 

[mariolj]

Hi & welcome to MrExcel.
Try this

Sub LoopFiles()

   Dim wb As Workbook
   Dim folder As String
   Dim file As String
   Dim extension As String
   Dim FldrPicker As FileDialog
   
   Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
   With FldrPicker
      .title = "Select A Target Folder"
      .AllowMultiSelect = False
      If .Show <> -1 Then GoTo NextCode
      folder = .SelectedItems(1) & ""
   End With
   
   extension = "*.csv"
   file = Dir(folder & extension)
   Do While file <> ""
      Set wb = Workbooks.Open(FileName:=MyPath & MyFile)
      DoEvents
      wb.Worksheets(1).Range("W1:w10").Copy
      With Application.ThisWorkbook.Sheets("sheet1")
         .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial
      End With
      'Close Workbook
      wb.Close savechanges:=False
      DoEvents
      'Get next file name
      MyFile = Dir
   Loop
End Sub

Thank you so much for welcoming me!
Your answer was really helpful! Now, I would like to copy entire column from each file and for this I changed my above code as:
a = wb.Worksheets(1).Range("W" & Rows.Count).End(xlUp).Row
wb.Worksheets(1).Range("W1" & a).Copy

However, it only select the last row in W instaed of W1:to the last row in each file. Any thoughts? What I am doing wrong here?

Thanks,
Mario

 

[Fluff]

It needs to be

wb.Worksheets(1).Range("W1:W" & a).Copy

 

[mariolj]

It needs to be

wb.Worksheets(1).Range("W1:W" & a).Copy

Thank you so much! It worked very well but when I start working with all my files now I have "overflow" error . Is there any way to optimize it? any thoughts?

 

[Fluff]

What line of code gives you the error?