将多个TXT文件导入现有Excel工作簿，追加至对应工作表空白行

原代码可将TXT文件导入对应名称的Excel工作表，但存在覆盖已有数据的问题，以下是调整后的代码，实现将TXT数据追加到对应工作表的下一个空白行：

Sub ImportTXTFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant
    Dim nextEmptyRow As Long

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="Text Files to Open")

    For Each txtfile In txtfilesToOpen
        ' 查找对应名称的工作表
        For Each xlsheet In ThisWorkbook.Worksheets
            If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet

ImportData:
        ' 获取工作表下一个空白行的行号
        nextEmptyRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

        ' 从TXT文件导入数据到空白行
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
          Destination:=ActiveSheet.Cells(nextEmptyRow, 1))
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = "|"

            .Refresh BackgroundQuery:=False
        End With

        ' 删除查询表，避免重复创建
        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next qt
    Next txtfile

    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"

    Set fso = Nothing
End Sub

关键修改说明 #

• 新增变量nextEmptyRow，通过Cells(Rows.Count, 1).End(xlUp).Row + 1计算第一列的下一个空白行位置
• 将数据导入的目标位置从起始行Cells(1,1)改为空白行Cells(nextEmptyRow, 1)，实现数据追加而非覆盖
• 调整ImportData标签位置，确保找到对应工作表后能直接执行数据导入逻辑

内容的提问来源于stack exchange，提问作者Julia Dudley