VBA Loop through folder and copy cells and paste

[Mike2502]

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

 '=============================================
   '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

 

[NdNoviceHlp]

You are not copying the range... you are setting a new range equal to some other range. However, this won't work...

.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...

.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