宏将文本文件导入到多个工作表中，我只想将所有文本文件导入一个工作表

Question

。。。并且每个文件之间有"***">

到目前为止，我拥有的是：

Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp 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
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
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:="|"
x = x + 1
While x <= UBound(FilesToOpen)
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    With wkbAll
        wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.count)
        .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:=sDelimiter
    End With
    x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

我可以从另一个网站复制这个，但我找不到一个代码，它可以将多个文件导入到一个文件中，并在每个文件之间添加一个间隔符。

Answer 1

您的代码非常完整。我添加了一个错误处理程序，以确保您在活动工作簿上有一个目标工作表，并进行了一些小的修改，在每个导入的TXT块后添加了一系列星号。

Sub CombineTextFiles()
    Dim FilesToOpen As Variant
    Dim x As Long
    Dim wsTXT As Worksheet, wkbAll As Workbook, wkbTemp As Workbook
    Dim sDelimiter As String
    On Error GoTo Missing_TXT_Ws
    Set wkbAll = ActiveWorkbook
    Set wsTXT = wkbAll.Worksheets("TXT_All")
    'uncomment the next line if you want to start fresh
    'wsTXT.Cells(1, 1).CurrentRegion.ClearContents
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    sDelimiter = Chr(124)   'e.g. "|"
    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
    For x = LBound(FilesToOpen) To UBound(FilesToOpen)
        'Debug.Print FilesToOpen(x)
        Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x), ReadOnly:=True)
        With wkbTemp.Sheets(1)
            .Columns(1).TextToColumns _
                  Destination:=.Cells(1, 1), _
                  DataType:=xlDelimited, _
                  TextQualifier:=xlDoubleQuote, _
                  ConsecutiveDelimiter:=False, _
                  Tab:=False, Semicolon:=False, _
                  Comma:=False, Space:=False, _
                  Other:=True, OtherChar:=sDelimiter
            .Cells(1, 1).CurrentRegion.Copy _
              Destination:=wsTXT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            wsTXT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = String(32, Chr(42))
        End With
        wkbTemp.Close False
    Next x
    With wsTXT
        If Not CBool(Application.CountA(.Rows(1))) Then .Rows(1).EntireRow.Delete
    End With
    GoTo ExitHandler
Missing_TXT_Ws:
    If Err.Number = 9 Then
        With wkbAll
            .Sheets.Add after:=Sheets(Sheets.Count)
            .Sheets(Sheets.Count).Name = "TXT_All"
        End With
        Resume
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
ExitHandler:
    Application.ScreenUpdating = True
    Set wsTXT = Nothing
    Set wkbAll = Nothing
    Set wkbTemp = Nothing
End Sub