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

Question

我正在尝试使用下面的 VBA 代码将一些文本文件导入 Excel。虽然代码为每个导入的文件生成了一个带有相应日期的交易销售编号列表，但我无法弄清楚如何将关联的交易销售编号放入每个导入文件行中的单独列中。我尝试过 RegEx，但在处理不同格式的销售编号时遇到了困难（示例文件中有一个示例）......有人可以帮忙吗？

在此先感谢

示例文本文件：

这是对 SER:SS09458GQPBXX201503191300WWPL0933 的销售查询回复 ************************************** ************************ SER:SS09458GQPBXX201503191300WWPL0933 的销售记录匹配 **********************原始文件********************** 文件数据源 POS 交易类型 EFT 日期 2015 年 3 月 19 日 12:00 PM 交易销售编号 LLRUMOLN120150319FLRPLIS08783 产品名称 吹风机 **** ***********销售文件# 1**************** 文件数据源 POS 交易类型 EFT 日期 Apr 23 2015 12:00PM 交易销售编号 PLVOLMJBD0960807420300 产品名称 吹风机 ***************销售文件 # 2*************** 文件数据源 POS 交易类型 EFT 日期 2015 年 5 月 28 日 12： 00PM 交易 销售编号 781266HO3 产品名称 吹风机 ***************销售文件# 3*************** 文件数据源 POS 交易类型 EFT日期 2015 年 5 月 10 日中午 12:00 交易 销售编号 CVFORM05061126581000433 产品名称 吹风机 ***************销售文件 # 4*************** 文件 D ata 来源 POS 交易类型 EFT 日期 2015 年 6 月 28 日下午 12:07 交易 销售编号 LLB01L32330772427059291FOLM400P00295 产品名称吹风机

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，我有一个 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

它适用于希伯来语和缩放/优先级。微软办公软件 2010/2013/2016(32/64)