Regex 使用VBA将文本文件导入Excel-具有相同分隔符的多个字符串
我正在尝试使用下面的VBA代码将一些文本文件导入Excel。虽然代码为每个导入的文件生成一个带有相应日期的交易销售编号列表，但我无法确定如何将关联的交易销售编号放入每个导入的文件行中的单独列中。我尝试过RegEx，但是销售数字的格式不同（示例文件中有每个销售数字的示例）。。。有人能帮忙吗 非常感谢 示例文本文件： 这是针对SER:SS09458GQPBXX201503191300WWPL0933*******************************************************************************************************************************SER的销售记录匹配：SS09458GQPBXX201503191300WWPL0933***************************************************************************************************************************************************************************************************************************************原始文件交易数据源日期：2015年3月12日交易记录类型EFT交易数据源编号：2011:19LLRUMOLN12050319FLRPLIS08783产品名称电吹风销售文件1****************文件数据源POS交易类型EFT日期2015年4月23日下午12:00交易销售编号PLVOLMJD096080720300产品名称电吹风销售文件2*************文件数据源POS交易类型EFT日期2015年5月28日中午12:00交易销售编号781266HO3产品名称电吹风**********销售文件*************文件数据源POS交易类型EFT日期2015年5月10日中午12:00交易销售编号CVForm050612658100433产品名称电吹风**********销售文件****4*************文件数据源POS交易类型EFT日期2015年6月28日中午12:07交易销售编号LLB01L23233077247059291FOLM400P00295产品名称吹风机Regex 使用VBA将文本文件导入Excel-具有相同分隔符的多个字符串,regex,excel,vba,Regex,Excel,Vba,我正在尝试使用下面的VBA代码将一些文本文件导入Excel。虽然代码为每个导入的文件生成一个带有相应日期的交易销售编号列表，但我无法确定如何将关联的交易销售编号放入每个导入的文件行中的单独列中。我尝试过RegEx，但是销售数字的格式不同（示例文件中有每个销售数字的示例）。。。有人能帮忙吗 非常感谢 示例文本文件： 这是针对SER:SS09458GQPBXX201503191300WWPL0933***************************************************
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"
Rabbie，我有一个XLSM文件，它读取6个CSV文件，并在其内部添加6张图纸。文本由制表符分隔 UTF-8 CSV头示例：
Customer Number Customer description Cust. Name-Lang 2 Status Phone Number Fax Number E-mail Address Type of Business Cust. Group Code
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
Customer Number Customer description Cust. Name-Lang 2 Status Phone Number Fax Number E-mail Address Type of Business Cust. Group Code
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
示例文本文件乱七八糟。我同意！当显示为电子邮件时，它看起来更整洁，但这就是它作为字符串的外观。不过，从我的角度来看，我对此无能为力……谢谢Kgprove——我无法让上面的代码按我想要的方式工作，所以我将修改它并尝试使用正则表达式，因为我有制表符和字符分隔的文件要处理。