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

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)