在同一個Excel工作表中導入多個文本文件

Question

我正在Excel上運行宏以導入多個.txt文件，並且將過濾器設置為文件名，因此它的作用類似於通配符。 每個文件具有相同的布局，以分號分隔，具有標題和11個列。

該宏工作正常，除了它可以“並排”或“水平”導入文件。 而不是導入下一個文件“下”（例如，第一個文件上移到第10行，然后下一個文件從第11行開始導入），它開始在下一個庫倫中導入（第一個文件在庫倫“ K”中，下一個開始在colunm L上導入）。

我該如何解決？ 這是代碼：

Sub Abrir_PORT()

    Dim Caminho As String
    Caminho = Sheets("DADOS").Cells(5, 5).Value
    Sheets("PORT").Select

    Dim FS
    Set FS = CreateObject("Scripting.FileSystemObject")

    Dim Filter As String: Filter = "ATENTO_TLMKT_REC*.txt"
    Dim dirTmp As String

    If FS.FolderExists(Caminho) Then
        dirTmp = Dir(Caminho & "\" & Filter)
        Do While Len(dirTmp) > 0
            Call Importar_PORT(Caminho & "\" & dirTmp, _
                            Left(dirTmp, InStrRev(dirTmp, ".") - 1))
            dirTmp = Dir
        Loop
    End If

End Sub

Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & iFullFilePath, _
        Destination:=Range("$A$1"))
        .Name = iFileNameWithoutExtension
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False

    iRow = 2

    Do While Sheets("PORT").Cells(iRow, 1) <> ""

                If Cells(iRow, 2) = IsNumber Then

                Else

                Rows(iRow).Select
                Selection.EntireRow.Delete

                iRow = iRow - 1
                contagem = contagem + 1

                End If

 iRow = iRow + 1

 Loop

    End With

End Sub

Answer 1

我還沒有測試過，但似乎要替換 ：

Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & iFullFilePath, _
        Destination:=Range("$A$1"))

與 ：

Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)

    afterLast = Cells(Rows.Count, 1).End(xlUp).Row + 1

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & iFullFilePath, _
        Destination:=Range("$A$" & afterLast))

會很好的。

Answer 2

添加檢查Range("A1")是否為空，如果A1為空， A1 A1開始...

經過測試和工作：

Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)

    Dim lngStartRow As Long
    With ActiveSheet
        If .Range("A1") = "" Then
            lngStartRow = 1
        Else
            lngStartRow = .Range("A" & .Rows.Count).End(xlUp).row + 1
        End If
    End With

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & iFullFilePath, _
        Destination:=Range("$A$" & lngStartRow))