CODEWITHSUNDEEP
excelvba
dreamaymc
dreamaymc

Reputation: 23

Extract specific data from multiple text files into one worksheet

I am designing a VBA function for collecting specific data from various text files. Currently, the function works perfect with single file. However, I would like to expand it for looping multiple text files.

Sub onlinecharges()
    
Workbooks.Add

Dim myFolder As String, mtext As String, textline As String, po_charges As Integer
myFolder = Application.GetOpenFilename()
    
Open myFolder For Input As #1
    
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
    
Close #1

po_charges = InStr(text, "NET CHARGES")

ActiveWorkbook.Sheets(1).Cells(2, 1).Value = Dir(myFolder)
ActiveWorkbook.Sheets(1).Cells(2, 2).Value = Abs(Mid(text, po_charges + 88, 8))
    
End Sub

The currently put the file name in A2, specific data in B2. My desire outcome is file names in A2 up to Ai, specific data in B2 to Bi. So, how I can add a loop for scanning multiple selected text files? Much appreciate! Thank you!

Upvotes: 0

Views: 552

Answers (1)

Elio Fernandes
Elio Fernandes

Reputation: 1420

In this solution it allows to select multiple text files.

Sub LoopAllSelectedTextFilesInAFolder()
    Dim rw As Integer: rw = 2
    
    ' Loop through all files in a folder
    Dim Filename As Variant
    Filename = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Select file(s)", MultiSelect:=True)
    
    ' Check if Cancel button was pressed
    If Not IsArray(Filename) Then
        MsgBox " No files selected!", vbInformation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' Loop through selected files
    Dim i As Integer
    For i = 1 To UBound(Filename)
        Open Filename(i) For Input As #1
            Do Until EOF(1)
                Line Input #1, textline
                Text = Text & textline
            Loop
        Close #1
        
        ' Write filename & Text
        ActiveWorkbook.Sheets(1).Cells(rw, 1).Value = Filename
        ActiveWorkbook.Sheets(1).Cells(rw, 2).Value = Text
        
        ' next row
        rw = rw + 1
        
        ' Clear Text
        Text = ""
    Next i
    
    Application.ScreenUpdating = True
End Sub

Upvotes: 2

Related Questions