Excel VBA導入文本數組定義問題

Question

我有一本包含30個數據標簽的工作簿，它們都遵循相同的過程：

1. 轉到模板工作簿中的標簽
2. 使用數據導入例程輸出CSV數據，將值轉儲到第7行以開始。
3. 完成后刪除第7行（它是我們不需要的無用標題）

該問題是由“導入文本文件”例程引起的，該例程需要為每個工作表分配一個數組。 我最終為每張紙寫了40行代碼，而沒有辦法改變例程。 這是一個由30部分組成的小節的第一部分（都具有相似的結構）：

    'Use the Get Data routine to dump the csv onto the sheet as text/dates where appropriate, then delete line 7
Sheets("Sheet Alpha info").Select                 'explicitly declare which sheet to dump onto
Application.CutCopyMode = False                 'this is good programming

    'this code section is the Get Data routine run in the UI, turned into VBA
With ActiveSheet.QueryTables.Add(Connection:= _
    "TEXT;" & ThisWorkbook.Path & "\sheet_alpha.CSV", _
    Destination:=Range("$A$7"))                 'important on every tab!
    '.CommandType = 0                           'this is only needed when you use the UI to do the routine, so currently commented out.
    .Name = "sheet_alpha"                       'could variablize this routine, but signficance of .Name is unknown in Import routine.
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437                     'no idea what this actually is. encoding for UTF-8?
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited            'not set width
    .TextFileTextQualifier = xlTextQualifierDoubleQuote              'yes, well-behaved CSV.
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True              'yes, well-behaved CSV.
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2) 'this damn array is why we repeat the code. Need a new array for each sheet.
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With

    'and now remove the useless header line
Rows("7:7").Select
Selection.Delete Shift:=xlUp

問題是：如何使該例程可變，並使其成為單個FOR循環，該循環還將每個TextFileColumnDataType數組定義為純文本數組（因此，Array（）每次填充2s）？

擴展：如果我想讓數組讀取其他數據類型（所以數組可能是Array（1、2、2、3、2、2、2）），該怎么辦？

Answer 1

此處實際上只有3個變量：源文件，目標范圍和字段類型的數組。

您可以將此代碼包裝在帶有這三個參數的子代碼中，並且應該可以正常工作。 唯一的挑戰是確定每個文件的確切字段類型（假設在這里很重要）

Sub Tester()
    'eg - call directly
    ImportFromText ThisWorkbook.Sheets("test").Range("A7"), _
                    ThisWorkbook.Path & "\test.csv", _
                    Array(2, 2, 2, 2, 2, 2, 2, 2, 2)

    '...or from a worksheet table
    Dim rw As Range
    For Each rw in ThisWorkbook.Sheets("Files").Range("A2:C32").Rows 

        ImportFromText ThisWorkbook.Sheets(rw.Cells(1).Value).Range("A7"), _
                    ThisWorkbook.Path & "\" & rw.Cells(2).Value, _
                    Split(rw.Cells(3).Value, "|")

    Next rw


End Sub


Sub ImportFromText(DestRange As Range, filePath As String, arrFieldTypes)

    Dim sht As Worksheet, qt As QueryTable

    Set sht = DestRange.Worksheet

    'clear any previous....
    Do While sht.QueryTables.Count > 0
        sht.QueryTables(1).Delete
    Loop
    sht.UsedRange.Clear

    Set qt = sht.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=DestRange)

    With qt
        '.CommandType = 0
        .Name = "sheet_alpha"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = arrFieldTypes
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

    DestRange.EntireRow.Delete Shift:=xlUp 'and now remove the useless header line

End Sub