导入多个文本文件以分隔现有工作簿中的工作表

Question

我有一个 excel 文件 (2013)（例如 test.xlsm）。 excel 文件包含基于文本文件的图表和数据透视表，每月刷新一次。我需要一个 VBA 代码，它可以从我的本地驱动器（我从服务器导入）导入多个文本文件，并将它们附加在这个 excel 文件的末尾（命名类似于文本文件名的工作表） .每个月，当我导入文本文件时，它必须用新文件替换这个数据表。

问题：
我在这个 link 中找到了一个 VBA 代码！它工作得很好。但我的问题是它将数据导入新打开的工作簿而不是现有工作簿。

解决方案

我修改了

中的行

Set wkbAll = ActiveWorkbook
wkbTemp.Sheets(1).Copy

到

Set wkbAll = ThisWorkbook
wkbAll.Activate
wkbTemp.Sheets(1).Copy After:=Sheets(wkbAll.Sheets.Count)

但我收到 错误 1004，未选择数据 以使用定界符

格式化数据

wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
    Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=False, _
    Tab:=False, Semicolon:=False, _
    Comma:=False, Space:=False, _
    Other:=True, OtherChar:="|"

解决方案 我发现了一些与我相似的问题（例如 this one），但其中 none 对我有用。

请帮我解决这个问题。

这是我修改过的代码

Sub copydata()

    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim sDelimiter As String


    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

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

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If


    Set wkbAll = Application.ActiveWorkbook
    x = 1

    With Workbooks.Open(fileName:=FilesToOpen(x))
        .Worksheets(1).Columns("A:A").TextToColumns _
            Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
            Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
            Other:=True, OtherChar:="|"
        .Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
        .Close False
    End With

    x = x + 1

    While x <= UBound(FilesToOpen)
        With Workbooks.Open(fileName:=FilesToOpen(x))
            .Worksheets(1).Columns("A:A").TextToColumns _
                Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, _
                Tab:=False, Semicolon:=False, _
                Comma:=False, Space:=False, _
                Other:=True, OtherChar:=sDelimiter
            .Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)

        End With
        x = x + 1
    Wend

    wkbAll.Save
ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Answer 1

在 OP 的新请求后编辑（见答案底部）

改变

wkbTemp.Sheets(1).Copy After:=Sheets(wkbAll.Sheets.Count)

到

wkbTemp.Sheets(1).Copy After:=wkbAll.Sheets(wkbAll.Sheets.Count)

因此您也可以更改整个部分：

Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
Set wkbAll = ThisWorkbook
wkbAll.Activate
wkbTemp.Sheets(1).Copy After:=Sheets(wkbAll.Sheets.Count)
wkbTemp.Close (False)

到

With Workbooks.Open(Filename:=FilesToOpen(x))
    .Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
    .Close False
End With

并完全摆脱 wkbTemp 变量

如果您需要将数据复制到同一工作簿的现有工作表中，则替换

With Workbooks.Open(Filename:=FilesToOpen(x))
    .Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
    .Close False
End With

和

With Worksheets("Data1") '<--| change "Data1" to your actual name of existing sheet where to paste data into
    .UsedRange.ClearContents
    Worksheets(1).UsedRange.Copy .Range("A1")
End With

导入多个文本文件以分隔现有工作簿中的工作表

import multiple text files to seperate sheets in the existing workbook

excel

vba

excel-2013