VBA looping through directory structure

[MarinM]

How do I write a code that will loop through a directory structure?

I have the following problem: in a directory C:\Documents\Means\ I have directories C:\Documents\Means\Measurement 2\ to C:\Documents\Means\Measurement 120\ each of these directories consists of .txt files. In each folder Measurement 2 to Measurement 120 there is one DBI.txt file which has only two rows. I need to loop through directory structure and import all DBI.txt files one after the other.
So far I managed to create this code:

Sub DBI()

Dim SourceWorkBook As Excel.Workbook
Dim DestWorkBook As Excel.Workbook
Dim wks As Worksheet
Set DestWorkBook = ThisWorkbook
DestWorkBook.Sheets.Add
Sheets("Sheet2").Name = "DBI"

Folder = "C:\Documents\Measurement 2\"
Set DestSht = DestWorkBook.Sheets("DBI")

'DestSht.Cells.Clear

FName = Dir(Folder & "DBI.txt")
Do While FName <> ""
Set Bk = Workbooks.Open(Filename:=Folder & FName)
' For Each Sht In Bk.Sheets
For a_counter = 2 To 120
j = 2 * a_counter

DestSht.Range("B" & j).Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Documents\Measurement 2\DBI.txt" _
, Destination:=Range("B" & j))
.Name = "DBI"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ":"
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Next a_counter
End Sub

How do I write in the loop procedure to go through all folders Measurement 2 to Measurement 120 and import it in sheet DBI in column B in even rows (B2:B3, B4:B5, B6:B7 etc.)?

 

[Krishnakumar]

Hi,

Try this

Public objFSO       As Object
Public objFolder    As Object
Public FileName     As Object
Public i            As Long
Public k()
Sub kTest()
    
    Dim StartFolder, j As Long, m As Long
    Dim txt As String, txtOpened
    Dim arrOutput(), n As Long, x, y
    Dim wbkActice As Workbook
    Dim wksDBI   As Worksheet
    
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    StartFolder = "C:\Documents\Measurement 2\"
    
    Set objFolder = objFSO.GetFolder(StartFolder)
    
    Set wbkActice = ThisWorkbook
    
    
    On Error Resume Next
    Set wksDBI = wbkActice.Worksheets("DBI")
    On Error GoTo 0
    
    If wksDBI Is Nothing Then
        Set wksDBI = wbkActice.Worksheets.Add
        wksDBI.Name = "DBI"
    End If
    
    For Each FileName In objFolder.Files
        If Right$(FileName, 4) = ".txt" Then
            i = i + 1
            ReDim Preserve k(1 To i)
            k(i) = StartFolder & FileName.Name
        End If
    Next
    SubFoldersFiles objFSO.GetFolder(StartFolder)
    
    ReDim arrOutput(1 To UBound(k) * 2, 1 To 4)
    
    For i = 1 To UBound(k)
        Set txtOpened = objFSO.opentextfile(k(i), 1)
        txt = txtOpened.readall
        txtOpened.Close
        x = Split(txt, vbCrLf)
        For m = 0 To UBound(x)
            y = Split(x(m), ":")
            n = n + 1
            For j = 0 To UBound(y)
                arrOutput(n, j + 1) = y(j)
            Next
        Next
        txt = ""
    Next
    With wksDBI
        .Range("b2").Resize(n, UBound(arrOutput, 2)).Value = arrOutput
    End With
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
End Sub
Sub SubFoldersFiles(Folder)
For Each SubFolder In Folder.SubFolders
    Set objFolder = objFSO.GetFolder(SubFolder.Path)
    For Each FileName In objFolder.Files
        If Right$(FileName, 4) = ".txt" Then
            i = i + 1
            ReDim Preserve k(1 To i)
            k(i) = objFolder & "\" & FileName.Name
        End If
    Next
    SubFoldersFiles SubFolder
Next
End Sub

HTH

 

[northwolves]

Try the following codes,please.

Sub DBI()
    Dim fo, x, s
    With CreateObject("Scripting.FileSystemObject")
        Set fo = .GetFolder("C:\Documents")
        For Each x In fo.SubFolders
            Open x.Path & "\DBI.TXT" For Input As #1
            s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
            Close #1
            [b65536].End(3).Offset(1, 0).Resize(UBound(s) + 1) = WorksheetFunction.Transpose(s)
        Next
    End With
End Sub

Regards
Northwolves

 

[northwolves]

Or:

Sub DBI()
    Dim Path$, f$, s
    Path = "C:\Documents\"
    f = Dir(Path, vbDirectory)
    Do While f > ""
        If Not f Like ".*" Then
            If (GetAttr(Path & f) And vbDirectory) = vbDirectory Then
                Open Path & f & "\DBI.TXT" For Input As #1
                s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
                Close #1
                [b65536].End(3).Offset(1, 0).Resize(UBound(s) + 1) = WorksheetFunction.Transpose(s)
            End If
        End If
        f = Dir
    Loop
End Sub

 

[MarinM]

@Krishnakumar, thank you much for your reply. It returns runtime error '9' on line "arrOutput(n, j + 1) = y(j)". I tried to debug and it looped few times For m = 0 To UBound(x) and then died. I do not understand this code, therefore I do not know why the error.

@northwolves - Wow, this is insanely simple. KudozBoth your solutions work perfectly!