I need to now make the loop loop through not just the base folder but also loop through sub folders e.g MainFolder>SubFolder>SubSubFolder and extract the 2 data values that i need. Also i need to rename the files from file extension to text files, i am currently changing the files manually to text files, i wish to automate it.
what my code currently does is that it will loop through the base folder and change text files to xlsx and then delete the text files , then extract 2 fixed position values from row A18 and A19,
Sub LoopAllFiles()
Dim sPath As String, sDir As String
sPath = "C:\Users\Desktop\Combine\"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sDir = Dir$(sPath & "*.txt", vbNormal)
'Txt to xlsx
Do Until Len(sDir) = 0
Workbooks.Open (sPath & sDir)
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=Left(.FullName, InStrRev(.FullName, ".")) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
Application.DisplayAlerts = True
End With
Kill "C:\Users\Desktop\Combine\*.txt"
sDir = Dir$
Loop
'Extract 2 fixed values in position A18,A19
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "C:\Users\Desktop\Combine\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
ActiveSheet.Name = "Sheet1"
Set copyrange = Sheets("Sheet1").Range("A18,A19")
Windows("TxtToXlsx&ScanFiles.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub