使用VBA将文本文件导入Excel-具有相同分隔符的多个字符串

Question

我正在尝试使用下面的VBA代码将许多文本文件导入Excel。 尽管代码生成了每个导入文件的具有相应日期的交易销售编号列表，但我无法弄清楚如何将关联的交易销售编号放入每个导入文件行的单独列中。 我已经尝试过RegEx，但在销售编号的不同格式方面都感到困惑（示例文件中包含每种格式的示例）...有人可以帮忙吗？

提前谢谢了

样本文本文件：

这是针对SER：SS09458GQPBXX201503191300WWPL0933的销售询价响应**************************************************** ****************** SER的销售记录匹配：SS09458GQPBXX201503191300WWPL0933 **********************原始文件* *********************文件数据源POS交易类型EFT日期2015年3月19日12:00 PM交易销售编号LLRUMOLN120150319FLRPLIS08783产品名称HAIRDRYER ******* ********销售文件编号1 ***************文件数据源POS交易类型EFT日期2015年4月23日12:00 PM交易销售编号PLVOLMJBD0960807420300产品名称HAIRDRYER * **************销售文件＃2 ***************文件数据源POS交易类型EFT日期2015年5月28日12:00 PM交易销售编号781266HO3产品名称HAIRDRYER ***************销售文件编号3 ***************文件数据源POS交易类型EFT日期5月10日2015 12:00 PM交易销售编号CVFORM05061126581000433产品名称HAIRDRYER ***************销售文件＃4 ***************文件数据 来源POS交易类型电子转帐日期2015年6月28日12:07 PM交易销售编号LLB01L32330772427059291FOLM400P00295产品名称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

拉比，我有一个XLSM文件，该文件读取6个CSV文件并将6张纸添加到其内部。 文本用TAB分隔。

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

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

与希伯来语和缩放/优先级配合使用时效果很好。 MS Office 2010/2013/2016（32/64）