macros将文本文件导入到多个工作表中，我只是希望它们全部导入到一个工作表中

…和每个文件之间有“***”

这是我到目前为止：

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 

我能够从另一个网站复制这个，但我一直没能find一个代码，导入多个到一个，并在每个文件之间添加一个间隔。

Answer 1

你的代码非常完整。 我添加了一个error handling程序，以确保在活动工作簿上有一个目标工作表以及一些小的修改，在每个导入的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) 'eg "|" 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