VBA multiple file Import to one help.

mike5

New Member
Joined
Nov 26, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi everyone this is my first time posting on here so be genital lol,
I have a problem with importing multiple files from a folder, I have manged to get the information to import from all the files however it is overlapping the previous data and i need it to go to the line after the first import. so i need it to select info from first file b50 to end as well as g50 to end and D50 to end and the paste that in the file im using in columns a,b,c which is does however once it has done that it goes to file 2 and collects the information from the same columns and pastes it into the file i am using ontop of the stuff that was previously imported

I am attaching what i have done so far, please remember that I am new to VBA. Thanks

VBA Code:
Const FOLDER_PATH = "C:\Users\[COLOR=rgb(255, 255, 255)]michael.allen[/COLOR]\Desktop\10cm 10s Cone 100 Bar Template Folder\Tip\"
'REMEMBER END BACKSLASH


Sub test666()

   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long 'output row
   Dim rowSource As Long

   Application.ScreenUpdating = False
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
  
   rowTarget = 2
  
   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If
  
   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False
  
   'set up the target worksheet
   Set wsTarget = Sheets("Cross Talk (2)")
  
   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""
     
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
   
    With wsSource
rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row, .Range("F" & .Rows.Count).End(xlUp).Row, .Range("G" & .Rows.Count).End(xlUp).Row)

End With

     
      'import the data
    With wsTarget

.Range("A" & rowTarget & ":A" & rowTarget + rowSource - 2).Value = wsSource.Range("b50:B" & rowSource).Value
.Range("B" & rowTarget & ":B" & rowTarget + rowSource - 2).Value = wsSource.Range("G50:G" & rowSource).Value
.Range("c" & rowTarget & ":c" & rowTarget + rowSource - 2).Value = wsSource.Range("D50:D" & rowSource).Value

Range("A2").Select

     
         'optional source filename in the last column
         .Range("g" & rowTarget).Value = sFile
      End With
     
      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
     
Loop

errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True
  
   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing



End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
 
Last edited by a moderator:

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Hi & welcome to MrExcel.
How about
VBA Code:
    With wsTarget
      .Range("A" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("b50:B" & rowSource).Value
      .Range("B" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("G50:G" & rowSource).Value
      .Range("c" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("D50:D" & rowSource).Value


     
         'optional source filename in the last column
         .Range("g" & rowTarget).Value = sFile
      End With
     
      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + rowSource - 49
      sFile = Dir()
 
Upvote 0
Solution
That is perfect, thank you so much but can I ask by changing it from 2 to 49 what has that actually changed (what is it looking for?)
Thanks again
 
Upvote 0
Because your copy range starts from row 50 you need to subtract 49 from rowsource here
VBA Code:
.Range("A" & rowTarget).Resize(rowSource - 49)
otherwise you will get 49 rows displaying #N/A
Then you need to increment rowTarget by the number of rows you have just copied which is rowsource -49
 
Upvote 0
Thankyou for explaining it to me, one final thing do you know if there is a way to change the constant folder path to one i select but wont have to select again once it starts the loop?
 
Upvote 0
How about
VBA Code:
Sub Mike()

   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim Fldr As Variant
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long 'output row
   Dim rowSource As Long
   
   With Application.FileDialog(4)
      .InitialFileName = "C:\Users\michael.allen\Desktop\"
      .AllowMultiSelect = False
      If .Show Then Fldr = .SelectedItems(1) & Application.PathSeparator
   End With
   Application.ScreenUpdating = False
   
   rowTarget = 2
   
   'check the folder exists
   
   'reset application settings in event of error
   On Error GoTo errHandler
   
   'set up the target worksheet
   Set wsTarget = Sheets("Cross Talk (2)")
   
   'loop through the Excel files in the folder
   sFile = Dir(Fldr & "*.xls*")
   Do Until sFile = ""
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(Fldr & sFile)
      Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
      
      With wsSource
         rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row, .Range("F" & .Rows.Count).End(xlUp).Row, .Range("G" & .Rows.Count).End(xlUp).Row)
      End With
      
      
      'import the data
      With wsTarget
         .Range("A" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("b50:B" & rowSource).Value
         .Range("B" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("G50:G" & rowSource).Value
         .Range("c" & rowTarget).Resize(rowSource - 49).Value = wsSource.Range("D50:D" & rowSource).Value
         
         'optional source filename in the last column
         .Range("g" & rowTarget).Value = sFile
      End With
      
      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + rowSource - 49
      sFile = Dir()
   Loop
   
errHandler:
   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub
 
Upvote 0
Glad to help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,223,948
Messages
6,175,573
Members
452,652
Latest member
eduedu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top