Forum Discussion
Solved
Loop through Multiple files in share folder
Hello All, I need to build a code which loops through multiple files in a folder and copy and paste the data to a template and drag formulas for 26 columns. I was able to build code to open o...
ok.
Sub AllFilesInFolder()
Dim strPath As String
Dim strFile As String
Dim wkbSource As Workbook
Dim lngRowFree As Long
'adopt path
strPath = ThisWorkbook.Path & "\Data\"
strFile = Dir(strPath & "*.xls*")
With Sheet1
.Range("A2:B" & .Rows.Count).Clear
Do While strFile <> ""
Set wkbSource = Workbooks.Open(strPath & strFile)
lngRowFree = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbSource.Worksheets("tbl_Preise").Range("A1:B5").Copy _
Destination:=.Range("A" & lngRowFree)
lngRowFree = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbSource.Worksheets("Sheet1").Range("A1:B1").Copy _
Destination:=.Range("A" & lngRowFree)
wkbSource.Close savechanges:=False
strFile = Dir
Loop
End With
End Sub
Hi,
you can use this macro to do similar things..
Sub DateinAusVerzeichnisVerarbeiten()
Dim strOrdner As String
Dim strDatei As String
Dim wkbQuelle As Workbook
Dim lngZeileFrei As Long
'PFad anpassen
strOrdner = ThisWorkbook.Path & "\Daten\"
strDatei = Dir(strOrdner & "*.xls*")
With Sheet1
.Range("A2:B" & .Rows.Count).Clear
Do While strDatei <> ""
'Debug.Print strDatei
Set wkbQuelle = Workbooks.Open(strOrdner & strDatei)
lngZeileFrei = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbQuelle.Worksheets("tbl_Preise").Range("A1:B5").Copy _
Destination:=.Range("A" & lngZeileFrei)
lngZeileFrei = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbQuelle.Worksheets("Sheet1").Range("A1:B1").Copy _
Destination:=.Range("A" & lngZeileFrei)
wkbQuelle.Close savechanges:=False
strDatei = Dir
Loop
End With
End Sub
Regards
Bernd
http://www.vba-Tanker.com - the database full of macros
Hello Berndvbatanker
Can you help me to get this code in English? Finding it difficult to understand the terms/words used.
Regards,
Chandrakanth.K
ok.
Sub AllFilesInFolder()
Dim strPath As String
Dim strFile As String
Dim wkbSource As Workbook
Dim lngRowFree As Long
'adopt path
strPath = ThisWorkbook.Path & "\Data\"
strFile = Dir(strPath & "*.xls*")
With Sheet1
.Range("A2:B" & .Rows.Count).Clear
Do While strFile <> ""
Set wkbSource = Workbooks.Open(strPath & strFile)
lngRowFree = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbSource.Worksheets("tbl_Preise").Range("A1:B5").Copy _
Destination:=.Range("A" & lngRowFree)
lngRowFree = .Range("A" & .Rows.Count).End(xlUp).Row + 1
wkbSource.Worksheets("Sheet1").Range("A1:B1").Copy _
Destination:=.Range("A" & lngRowFree)
wkbSource.Close savechanges:=False
strFile = Dir
Loop
End With
End Sub
