VBA Loop through folder and copy cells and paste

Mike2502

Board Regular
Joined
Jan 19, 2020
Messages
143
Office Version
  1. 2010
Hi guys

The code below loops into DIR and copies specific cells however, it will paste the first line of data from the first excel file in the folder but then stops?

I have tried to rename and save the file we loop in below - could it be this?

I'm unsure to what the problem is;

Thanks in advance

VBA Code:
 '=============================================
   '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 Filename As String
   Dim RowTarget As Long         'output row
   Dim MyDate
   Dim Month
   
   Const FOLDER_PATH = "filepathhere\"  'REMEMBER END BACKSLASH
   
   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("Sheet1")
   
   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""
   
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1)
      
      'import the data
      With wsTarget
         .Range("A" & RowTarget).Value = wsSource.Range("B4:C4").Value  
         .Range("B" & RowTarget).Value = wsSource.Range("B5:C5").Value  
         .Range("C" & RowTarget).Value = wsSource.Range("C9:D9").Value  
         .Range("D" & RowTarget).Value = wsSource.Range("E4").Value  
         .Range("E" & RowTarget).Value = wsSource.Range("B33:C33").Value    
         .Range("F" & RowTarget).Value = wsSource.Range("B34:C34").Value    
         .Range("G" & RowTarget).Value = wsSource.Range("A26:E30").Value    '
         .Range("I" & RowTarget).Value = sFile 'Source File
         
          Filename = Range("A" & RowTarget).Value = wsSource.Range("B4:C4").Value  
      End With

    MyDate = Format(Date, "yyyymmdd")
    Month = Format(Date, "mmmm")
    ActiveWorkbook.SaveAs ("filepathhere" & ".xlsx")
    
    'ActiveWorkbook.SaveAs ("C:\file\" & Format(Now(), "yyyymmdd - ") & FileName & ".xlsx")
    Application.DisplayAlerts = False
    wbSource.Close
    RowTarget = RowTarget + 1
    sFile = Dir()
   Loop
   
errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True

   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,776
You are not copying the range... you are setting a new range equal to some other range. However, this won't work...
Code:
.Range("A" & RowTarget).Value = wsSource.Range("B4:C4").Value
You are trying to put the B4:C4 range into 1 cell(range). You need to resize the new range...
Code:
.Range("A" & rowtarget).Resize(1, 2) = wsSource.Range("B4:C4").Value
I don't think this will help your file access problem however it's probably a good place to start. HTH. Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,130,051
Messages
5,639,773
Members
417,112
Latest member
PachRedoc

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
Top