Loop Through Files in a folder

Contributor

Hello All,

 

I have built a code to loop through multiple files in a folder and then try to consolidate in one sheet.

I am able to accomplish but i am failing when ever my source file have only one line item to copy.

I am failing at code " Range(Selection, Selection.End(xlDown)).Select" . I used this to copy entire rows from A7 row. It works when i have more than one line item. But code fails when i have only one line item.

 

And also need to help to change the target sheet. i need to paste it in new workbook than this work book. Below is my code

 

Need help

 

Option explicit


Const FOLDER_PATH = "C:\Users\h140738\Desktop\New folder (4)\" 'REMEMBER END BACKSLASH


Sub ImportWorksheets()
'=============================================
'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

rowTarget = 7

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

'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

'import the data

With wsTarget
Range("A7:BI7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Loop through files.xlsm").Activate
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.PasteSpecial


End With

'close the source workbook, increment the output row and get the next file
Application.DisplayAlerts = False
wbSource.Close SaveChanges:=False
Application.DisplayAlerts = True
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

 

1 Reply

@Chandrakanth K Do you want/need to do this in VBA? Power Query can do this easily. See an example here https://www.youtube.com/watch?v=a7E29H5ZUmE