使用VBA導入具有不同定界符的多個文本文件

Question

更新的代碼和問題（5/9/2018 1:53 PM Eastern）

我在嘗試使用兩個不同的定界符將多個數據文本文件導入到固定的工作表（“原始數據”）時遇到問題。 我正在使用Application.GetOpenFilename允許用戶從文件夾中選擇多個文本文件。 這些文件包含一個以分號分隔的標題行，然后是幾行以逗號分隔的數據。 在單個文本文件中，此格式可以重復多次（這是一個檢查日志文件，它針對每次檢查運行記錄數據並將其附加到同一文本文件中，即標題行1，數據的某些行，標題行2，更多的行數據，標題行3，更多行數據等）

我已經根據在StackOverflow.com上找到的其他示例嘗試了幾種方法來解決此問題，但是我似乎無法成功地將解決方案網格化，無法提出一種可以導入具有兩個不同文本的單個或多個文本文件的解決方案每個文件中的定界符。 我無法更改原始文本文件的格式或內容，因此無法搜索和將不同的分隔符替換為單個分隔符。

這是我在附帶的VBA代碼中遇到的其余問題：

導入多個文本文件時，在文件之間插入空白行，這會破壞.TextToColumns部分。 在導入所選的第二個文件時，它還要求替換現有數據。 使用逗號和分號作為定界符，從多個文本文件導入數據是否有更有效或更好的方法？

在本地硬盤驅動器上的固定路徑內，每個新訂單號都會創建一個新的子文件夾來存儲.txt數據文件（即C：\\ AOI_DATA64 \\ SPC_DataLog \\ IspnDetails \\ 123456-7）。 有沒有一種方法可以提示用戶輸入子文件夾名稱（123456-7），VBA腳本將自動從該子文件夾導入所有.txt文件，而不是使用Application.GetOpenFilename？

這是我要導入的數據文件之一的截短版本。 實際文件在數據行之間沒有空格。 在本示例中，我將它們分開以清楚地顯示文本文件中的每一行。

[StartIspn];Time=04/19/18 12:43:15;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=T;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;

KC17390053F,VIA5F,M North,A8,85.0,45.0,96.0,23.2,9.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,

KC17390053F,VIA3F,M North,A8,85.0,45.0,96.0,22.3,22.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,

KC17390053F,FMI1F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,

KC17390053F,FMI13F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,

[StartIspn];Time=04/19/18 14:28:10;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=B;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;

KC17390066B,VIA5B,M North,A8,70.0,50.0,92.0,-38.8,-3.7,0.0,0.0,0.0,50.0,0.0,0.0,0.0,

KC17390066B,VIA6B,M North,A8,70.0,50.0,93.0,-37.7,-23.6,0.0,0.0,0.0,50.0,0.0,0.0,0.0,

KC17390066B,FMI12B,S South,A13,4140.4,0.0,2.0,3.5,129.6,0.0,0.0,0.0,0.0,0.0,0.0,0.0,

KC17390066B,FMI24B,S South,A13,2128.7,0.0,2.0,3.5,119.1,0.0,0.0,0.0,0.0,0.0,0.0,0.0,

到目前為止，這是我導入多個文本文件的方法：

Sub Import_DataFile()

' Add an error handler
On Error GoTo ErrorHandler

' Speed up this sub-routine by turning off screen updating and auto calculating until the end of the sub-routine
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Define variable names and types
Dim OpenFileName As Variant
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim dLastRow As Long
Dim destCell As Range

' Select the source folder and point list file(s) to import into worksheet
OpenFileName = Application.GetOpenFilename( _
               FileFilter:="AOI Inspection Results Data Files (*.txt), *.txt", _
               Title:="Select a data file or files to import", _
               MultiSelect:=True)

' Import user selected file(s) to "Raw Data" worksheet
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
    fn = FreeFile
    Open OpenFileName(n2) For Input As #fn
    Application.StatusBar = "Processing ... " & OpenFileName(n2)

    Do While Not EOF(fn)
        Line Input #fn, RawData
        TargetRow = TargetRow + 1
        Worksheets("Raw Data").Range("B" & TargetRow).Formula = RawData

    Loop

    Next n2

    Close #fn

 Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)

   With rngTarget

    .TextToColumns Destination:=destCell, DataType:=xlDelimited, _
     TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
     Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
     FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

    End With

    Else: MsgBox "The selected file is not the correct format for importing data."

    Exit Sub

    End If

Next

' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"

' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit

' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then

' Display a message to the user including the error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
       "Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If

End Sub

Answer 1

許多問題...讓我給出一些提示。

1. 提示用戶輸入工作目錄：

    Dim fDlg As FileDialog ' dialog box object Dim sDir As String ' selected path Dim iretval As Long ' test Set fDlg = Application.FileDialog(msoFileDialogFolderPicker) sDir = conDEFAULTPATH ' init With fDlg .Title = "Select a Folder" .AllowMultiSelect = False .InitialFileName = sDir iretval = .Show If iretval = -1 Then sDir = .SelectedItems(1) End With Set fDlg = Nothing ' drop object If sDir = vbNullString Then MsgBox "Invalid directory" Else If Right$(Trim$(sDir), 1) <> Application.PathSeparator Then _ sDir = Trim$(sDir) & Application.PathSeparator' append closing backslash to pathname End If 

2. 將文件收集到緩沖區

    Dim FileBuf(100) as string, FileCnt as long FileCnt=0 FileBuf(FileCnt)=Dir(sDir & "*.txt") Do While FileBuf(FileCnt) <> vbnullstring FileCnt = FileCnt + 1 FileBUf(FileCnt) = Dir Loop 

3. 減少定界符的數量：只需使用replace

    RawData = Replace(RawData, ";", ",") 

4. 對於空行，我沒有任何線索，盡管這可能是源文件中空行（可能是EOF）的結果。 那么，如果您在復制前檢查該行怎么辦：

    If len(trim(RawData)) > 0 Then TargetRow = TargetRow + 1 Worksheets("Raw Data").Range("B" & TargetRow) = RawData End If 

請注意，我已經刪除了.Formula 。 您正在使用價值觀。

5. 要設置目標范圍：您應該省略.Address 。 要選擇范圍中的最后一個單元格，應使用.End(xlUp)這樣：

    Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlUp)) 

我更喜歡使用直接單元格引用，因此-正如您確切地知道最后一行-我會這樣進行：

Set rngTarget =  Worksheets("Raw Data").Range(Cells(1, 2), Cells(TargetRow, 2))

祝好運！