使用VBA將文本文件導入到Excel - 具有相同分隔符的多個字符串

Question

我試圖使用下面的VBA代碼將一些文本文件導入到Excel中。雖然代碼生成的交易銷售數字列表中包含每個導入文件的相應日期，但我無法確定如何在每個導入的文件行中將相關聯的交易銷售數字分成不同的列。我嘗試了RegEx，但與銷售號碼的不同格式掙扎（每個例子都在示例文件中）......任何人都可以幫忙嗎？

提前感謝

示例文本文件：

這是SER銷售查詢響應：SS09458GQPBXX201503191300WWPL0933 ********************* **************************************銷售記錄匹配對於SER：SS09458GQPBXX201503191300WWPL0933 ***** *****************原始文件**********************文件數據源POS交易類型EFT日期Mar 19 2015 12:00 PM交易銷售編號LLRUMOLN120150319FLRPLIS08783商品名稱HAIRDRYER ***************銷售文件＃1 ***************文件數據源POS交易類型EFT日期Apr 23 2015 12:00 PM交易銷售編號PLVOLMJBD0960807420300產品名稱HAIRDRYER ******* ********銷售檔案＃2 ***************檔案資料來源POS交易類型EFT日期5月28日2015年12月30日交易銷售編號781266HO3產品名稱HAIRDRYER * **************銷售文件＃3 ***************文件數據來源POS交易類型EFT日期5月10日2015年12月30日交易銷售編號CVFORM05061126581000433產品名稱HAIRDRYER ***************銷售文件＃4 ***************文件數據來源POS交易類型電匯日期6月28日2015年下午12點07分交易銷售數量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）