Quantcast
Channel: Active questions tagged excel - Stack Overflow
Viewing all articles
Browse latest Browse all 88809

How to loop subfolder and rename file

$
0
0

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

Viewing all articles
Browse latest Browse all 88809

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>