Importing text file to Excel with VBA - multiple strings with same delimiter

Question

I'm trying to import a number of text files into Excel using the VBA code below. Whilst the code produces a list of the Transaction Sales Numbers with corresponding date for each file imported, I can't work out how to get the associated Transaction Sales Numbers into seperate columns in each imported file row. I have tried RegEx but struggled with the differing formats of the Sales Numbers (an example of each is in the sample file)... Can anyone help?

Many thanks in advance

Sample text file:

This is sales enquiry response for SER:SS09458GQPBXX201503191300WWPL0933 *********************************************************** Sales record match For SER:SS09458GQPBXX201503191300WWPL0933 **********************Original File********************** File Data Source POS Type of Transaction EFT Date Mar 19 2015 12:00PM Transaction Sales Number LLRUMOLN120150319FLRPLIS08783 Product Name HAIRDRYER ***************Sales File # 1*************** File Data Source POS Type of Transaction EFT Date Apr 23 2015 12:00PM Transaction Sales Number PLVOLMJBD0960807420300 Product Name HAIRDRYER ***************Sales File # 2*************** File Data Source POS Type of Transaction EFT Date May 28 2015 12:00PM Transaction Sales Number 781266HO3 Product Name HAIRDRYER ***************Sales File # 3*************** File Data Source POS Type of Transaction EFT Date May 10 2015 12:00PM Transaction Sales Number CVFORM05061126581000433 Product Name HAIRDRYER ***************Sales File # 4*************** File Data Source POS Type of Transaction EFT Date Jun 28 2015 12:07PM Transaction Sales Number LLB01L32330772427059291FOLM400P00295 Product Name HAIRDRYER

Option Explicit

Sub Sales_File_Extractor()

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
Dim TSN_Start As String, TSN_End As String 
Dim Date_Start As String,   Date_End As String
Dim textline As String, text As String

'Setup
Application.ScreenUpdating = False                      'speed up macro execution
Application.EnableEvents = False                        'turn off other macros for now
Application.DisplayAlerts = False                       'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("SALES")             'sheet report is built into

With wsMaster
    NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data

'Path and filename (edit this section to suit)
fPath = "C:\Users\burnsr\desktop\sales"
fPathDone = fPath & "Imported\"      'remember final \ in this string
On Error Resume Next
MkDir fPathDone                      'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.txt*")        'listing of desired files, edit filter as desired

Do While Len(fName) > 0
        Open (fPath & fName) For Input As #1
    Do Until EOF(1)
        Line Input #1, textline
        text = text & textline       'second loop text is already stored -> see reset text
    Loop
    Close #1

    On Error Resume Next

    .Cells(NR, "A").Value = fName

    Date_Start = InStr(text, "Date                              ")                     'position of start delimiter
    Date_End = InStr(text, "Transaction Sales Number")                                 'position of end delimiter
    .Cells(NR, "C").Value = Mid(text, Date_Start + 34, Date_End - Date_Start - 34)     'position number is length of start string

    TSN_Start = InStr(text, "Transaction Sales Number          ")                      'position of start delimiter
    TSN_End = InStr(text, "Product Name")                                              'position of end delimiter
    .Cells(NR, "B").Value = Mid(text, TSN_Start + 34, TSN_End - TSN_Start - 34)        'position number is length of start string
    'How to get all other successive values in columns?

    text = ""                                                                       'reset text

        Close #1                                                                    'close file
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1                            'next row
        Name fPath & fName As fPathDone & fName                                     'move file to IMPORTED folder
        fName = Dir                                                                 'ready next filename
Loop

End With

ErrorExit:    'Cleanup
Application.DisplayAlerts = True         'turn system alerts back on
Application.EnableEvents = True          'turn other macros back on
Application.ScreenUpdating = True        'refreshes the screen

MsgBox "Import completed"

Answer 1

Rabbie, I have an XLSM file that reads 6 CSV files and adds 6 sheets to inside itself. Text are TAB delimited.

UTF-8 CSV Headers Example:

Customer Number Customer description    Cust. Name-Lang 2   Status  Phone Number    Fax Number  E-mail Address  Type of Business    Cust. Group Code

VBA:

    Function IsOpen(File$) As Boolean
    Dim FN%
    FN = FreeFile
    On Error Resume Next
    Open File For Random Access Read Write Lock Read Write As #FN
    Close #FN
    IsOpen = Err
End Function
Public Sub Load_Data()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    allName = Worksheets("START").Cells(6, "B").Value
    tmpltName = Worksheets("START").Cells(4, "B").Value
    savePath = Worksheets("START").Cells(3, "B").Value

    Set currBook = ActiveWorkbook
    Set prevsheet = ActiveSheet

    'Load all ZOOM files
    i = 2
    For Each n In Worksheets("START").Range("E2:E8")
        On Error Resume Next
        currBook.Sheets(n.Text).Select
        If Not Err Then
            Err.Clear
            currBook.Worksheets(n.Text).Delete
        End If
        Sheets.Add(Before:=Sheets("START")).Name = n.Text
        ' Checking if file is opened
        If Not IsOpen(Worksheets("START").Cells(i, "F").Value) Then
            ' Loadd CSV file
            LoadCSV Worksheets("START").Cells(i, "F").Value, n.Text
        End If

       ' List of combining fields
       ' Find column with combining field
        With Worksheets(n.Text).Columns("A:DZ")
            Set result = .Find(What:=Worksheets("START").Cells(i, "G").Value, LookIn:=xlValues)
            If result Then
                combFields.Add result.Address, n.Text
            End If
        End With
        i = i + 1
    Next n

    ' Find column with combining field in Peoples
    combFieldPeople = combFields.Item("peoples")
    ' Find column with combining field in Companies
    combFieldCompany = combFields.Item("companies")

    ' Find company names field in "companies"
    With Worksheets("companies").Columns("A:DZ")
        Set result = .Find(What:=Worksheets("START").Cells(3, "I").Value, LookIn:=xlValues)
        If result Then
            companyNameField = result.Address
        End If
    End With

    ' Find column with "CopyToExcel" checkbox for Peolles
    With Worksheets("peoples").Columns("A:DZ")
        Set result = .Find(What:=Worksheets("START").Cells(2, "H").Value, LookIn:=xlValues)
        If result Then
            copyUserField = result.Address
        End If
    End With


    ' Find column with "CopyToExcel" checkbox for "Companies"
    With Worksheets("companies").Columns("A:DZ")
        Set result = .Find(What:=Worksheets("START").Cells(3, "H").Value, LookIn:=xlValues)
        If result Then
            copyField = result.Address
        End If
    End With

    ' Remove unnecessary organizations
    startBook.Activate
    With Worksheets("companies")
        .Activate
        .AutoFilterMode = False
        fldNum = .Range(copyField).Column
        .UsedRange.AutoFilter Field:=fldNum, Criteria1:="Y"
        ActiveCell.CurrentRegion.Select ' copy unique values
        nRow = Selection.Rows.Count
        Selection.Copy
        '.UsedRange.AutoFilter
        Worksheets.Add.Name = "tmp1"
        ActiveSheet.Range("A1").Select
        ActiveSheet.Paste
        Worksheets("companies").Delete
        Worksheets("tmp1").Name = "companies"
    End With

    Worksheets("START").Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub
Function LoadCSV(fName As String, shName As String)
    ActiveWorkbook.Worksheets(shName).Activate
    iPath = ThisWorkbook.Path
    fullFileName = iPath & "\" & fName
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" + fullFileName, Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = fullFileName
        .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
        '.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        '    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
        '    , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        '    1, 1, 1, 1, 1)
        .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Function

It works fine with Hebrew and Zoom/Priority. MS Office 2010/2013/2016(32/64)