Question

...并且有＆＃34; ***＆＃34;每个文件之间

这是我到目前为止所拥有的：

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

宏将文本文件导入多个工作表，我只想将它全部导入到一个工作表中

1 个答案: