Note: The other languages of the website are Google-translated. Back to English

如何将一个文件夹中的多个文本文件导入一个工作表?

例如,这里有一个包含多个文本文件的文件夹,您要做的就是将这些文本文件导入到单个工作表中,如下图所示。 有没有什么技巧可以将文本文件从一个文件夹快速导入到一张纸中,而不是一个一个地复制文本文件?

使用VBA将多个文本文件从一个文件夹导入到一张工作表中

使用Kutools for Excel将文本文件导入活动单元格 好主意3


这是一个VBA代码,可以帮助您将所有文本文件从一个特定的文件夹导入到新的工作表中。

1.启用要导入文本文件的工作簿,然后按 Alt + F11键 启用键 Microsoft Visual Basic应用程序 窗口。

2。 点击 插页 > 模块,将下面的VBA代码复制并粘贴到 模块 窗口。

VBA:将多个文本文件从一个文件夹导入到一张工作表

Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3。 按 F5 显示对话框,然后选择一个文件夹,其中包含要导入的文本文件。 看截图:
doc从文件夹导入文本文件1

4。 点击 OK。 然后,文本文件已作为新工作表分别导入到活动工作簿中。
doc从文件夹导入文本文件2


如果要将一个文本文件导入到特定的单元格或范围,可以应用 Kutools for Excel在光标处插入文件 效用。

Kutools for Excel, 与超过 300 方便的功能,使您的工作更加轻松。 

免费安装 Kutools for Excel,请执行以下操作:

1.选择要导入文本文件的单元格,然后单击 Kutools 加 > 进出口 > 在光标处插入文件。 看截图:
doc从文件夹导入文本文件3

2.然后弹出一个对话框,单击 浏览 显示 选择一个文件 插入单元格光标位置对话框中,然后选择 文本文件 从下拉列表中,然后选择要导入的文本文件。 看截图:
doc从文件夹导入文本文件4

3。 点击 可选 > Ok,并且已在光标位置插入了指定文本文件,请参见屏幕截图:
doc从文件夹导入文本文件5


最佳办公效率工具

Kutools for Excel解决了您的大多数问题,并使您的生产率提高了80%

  • 重用: 快速插入 复杂的公式,图表 以及您以前使用过的任何东西; 加密单元 带密码 创建邮件列表 并发送电子邮件...
  • 超级公式栏 (轻松编辑多行文本和公式); 阅读版式 (轻松读取和编辑大量单元格); 粘贴到过滤范围...
  • 合并单元格/行/列 不会丢失数据; 拆分单元格内容; 合并重复的行/列...防止细胞重复; 比较范围...
  • 选择重复或唯一 行; 选择空白行 (所有单元格都是空的); 超级查找和模糊查找 在许多工作簿中; 随机选择...
  • 确切的副本 多个单元格,无需更改公式参考; 自动创建参考 到多张纸; 插入项目符号,复选框等...
  • 提取文字,添加文本,按位置删除, 删除空间; 创建和打印分页小计; 在单元格内容和注释之间转换...
  • 超级滤镜 (将过滤方案保存并应用于其他工作表); 高级排序 按月/周/日,频率及更多; 特殊过滤器 用粗体,斜体...
  • 结合工作簿和工作表; 根据关键列合并表; 将数据分割成多个工作表; 批量转换xls,xlsx和PDF...
  • 超过300种强大功能. 支持 Office / Excel 2007-2021 和 365。支持所有语言。 在您的企业或组织中轻松部署。 完整功能 30 天免费试用。 60 天退款保证。
kte选项卡201905

Office选项卡为Office带来了选项卡式界面,使您的工作更加轻松

  • 在Word,Excel,PowerPoint中启用选项卡式编辑和阅读,发布者,Access,Visio和Project。
  • 在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。
  • 每天将您的工作效率提高50%,并减少数百次鼠标单击!
officetab底部
按评论排序
注释 (46)
4中的5评分 · 1评级
该评论由网站上的主持人最小化
子测试()
'更新通过Extendoffice6/7/2016
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
设置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那么
对于 I = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)
出错时继续下一步
ActiveSheet.Name = xWb.Name
出错时转到 0
xWb.Close 错误
下一页
结束如果
END SUB

这段代码有帮助,但我想要

制表符,分号,空格 true 如何做到这一点请帮助我
该评论由网站上的主持人最小化
将文本文件转换为工作表后是否要保留空格(分隔符)?
该评论由网站上的主持人最小化
这也是我的问题,这段代码是真的。 但在将文本文件转换为 excel 后,它不会保留分隔符。
该评论由网站上的主持人最小化
你能上传文本文件和你想要的结果吗?
该评论由网站上的主持人最小化
我也有同样的问题。 txt 文件都在单独的工作表中,代码忽略了两列之间的空格
该评论由网站上的主持人最小化
你好,Des 和 PB Rama Murty,下面的代码可以在将文本文件导入工作表时根据空格或制表符将数据拆分为列。 你可以试一试。

子 ImportTextToExcel()
'更新通过Extendoffice20180911
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
将 xIntRow 变暗
暗淡 xFNum, xFArr 只要
将 xStrValue 调暗为字符串
将 xRg 调暗为范围
暗淡 xArr
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
设置 xToBook = ThisWorkbook
出错时继续下一步
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那么

对于 I = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 错误
xIntRow = ActiveCell.CurrentRegion.Rows.Count
对于 xFNum = 1 到 xIntRow
设置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那么
对于 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那么
xRg.Value = xArr(xFArr)
设置 xRg = xRg.Offset(ColumnOffset:=1)
结束如果
下一页
结束如果
下一页
下一页
结束如果
Application.ScreenUpdating =真
END SUB
该评论由网站上的主持人最小化
如果要根据逗号将数据拆分为列,需要进行哪些更改
该评论由网站上的主持人最小化
如果我需要根据逗号将数据放入列中,需要进行哪些更改?
该评论由网站上的主持人最小化
我使用了它并且它有效,但我希望将它全部保存到一张纸上,因为每张纸都是相同的信息,它们只是每天的日志文件。
所以我需要结合
文件夹中的所有项目到一张纸
子 ImportCSVsWithReference()
'更新由 KutoolsforExcel20151214
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
将 xIntRow 变暗
暗淡 xFNum, xFArr 只要
将 xStrValue 调暗为字符串
将 xRg 调暗为范围
暗淡 xArr
出错时转到 ErrHandler
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
设置 xSht = ThisWorkbook.ActiveSheet
If MsgBox("导入前清除现有工作表?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
执行 xFile <> ""
设置 xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close 错误
xFile = 目录
循环
Application.ScreenUpdating =真
退出小组
错误处理程序:
MsgBox "没有 txt 文件", , "Kutools for Excel"
END SUB

这个使用空格添加到每个列

子 ImportTextToExcel()
'更新通过Extendoffice20180911
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
将 xIntRow 变暗
暗淡 xFNum, xFArr 只要
将 xStrValue 调暗为字符串
将 xRg 调暗为范围
暗淡 xArr
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
设置 xToBook = ThisWorkbook
出错时继续下一步
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那么

对于 I = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 错误
xIntRow = ActiveCell.CurrentRegion.Rows.Count
对于 xFNum = 1 到 xIntRow
设置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那么
对于 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那么
xRg.Value = xArr(xFArr)
设置 xRg = xRg.Offset(ColumnOffset:=1)
结束如果
下一页
结束如果
下一页
下一页
结束如果
Application.ScreenUpdating =真
END SUB
该评论由网站上的主持人最小化
如果我的 Txt 文件包含使用逗号分隔的内容怎么办?
该评论由网站上的主持人最小化
您可以先使用 Find and Replace 功能将逗号替换为空格,然后应用上述方法之一将其转换为 Excel 文件。
该评论由网站上的主持人最小化
没有办法在代码中更改它吗? 我必须用 130 个文件来做这个
该评论由网站上的主持人最小化
同样的问题
该评论由网站上的主持人最小化
对于那些仍然需要帮助的人,请将 xArr = Split(xRg.Text, " ") 替换为 xArr = Split(xRg.Text, ",")。
该评论由网站上的主持人最小化
当我按照给定的方式运行模块时,它会将每个 .txt 文件添加为新工作表,而不是作为现有工作表的新行。 有没有办法将其作为输出而不是每个 .txt 文件的新工作表来实现?
该评论由网站上的主持人最小化
您的意思是将所有文本文件合并到一张纸上吗?
该评论由网站上的主持人最小化
是的,这也是我想要的。
该评论由网站上的主持人最小化
嗨,Davinder,你可以试试下面的 vba 代码。
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub
该评论由网站上的主持人最小化
该代码非常有用,它是我发现的唯一可以批量获取 txt 文件的代码,我需要的修复也是 Joyce 和 Davinder 所追求的。
它是提取 .txt 文件并将它们全部粘贴到特定列中,比如说“N”列。

另外,需要知道是否可以为导入的 .txt 文件添加“if 条件”,如下所示。
如果 .txt 文件以字母“A”开头,则粘贴在以单元格“N1”开头的“工作表 2”上
如果 .txt 文件以字母“B”开头,则粘贴在以单元格“N2”开头的“Sheet 2”上
否则 MsgBox 为“无法识别的 .txt 文件用途”。

在此先谢谢
该评论由网站上的主持人最小化
我有这段代码对我有用,但我仍然需要在其中进行一些更改。

*我希望它粘贴在同一张纸上而不打开新纸然后复制它,因为它需要更长的时间。

*如果导入的txt文件以字母A开头,则需要插入条件if粘贴到工作表1上,如果以字母B开头,则导入到工作表2


子 testcopy3()
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
朦胧我
将 LastRow 变暗
昏暗范围
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
范围(“N2”)。选择
设置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那么
对于 i = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.激活
'选择并复制txt数据
范围(选择,选择。结束(xlDown))。选择
选择.复制
xToBook.激活
ActiveSheet.Paste
选择.结束(xlDown).偏移(1).选择
出错时继续下一步
出错时转到 0
xWb.Close 错误
下一页
结束如果
END SUB
该评论由网站上的主持人最小化
对不起,我的手被绑住了
该评论由网站上的主持人最小化
嗨,我的代码运行但只导入第一个文件。 它说复制有一个方法错误。 调试器突出显示以下代码行。 有任何想法吗?


xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)
该评论由网站上的主持人最小化
我也遇到了同样的问题,有找到解决办法吗?
该评论由网站上的主持人最小化
嘿,凯蒂,
我知道您的评论已经很老了,但是我遇到了同样的问题并以这种方式修复了它:该模块必须插入到活动 .xlsx 项目的子文件夹中。 我错误地将代码复制到我的 PERSONAL.XLSB 的子文件夹中,我通常在其中存储我的宏,它与我的其他宏一起使用,但不是与这个宏。
该评论由网站上的主持人最小化
如果您不希望在重新执行模块时重复,您将如何删除 vba 代码中的工作表?
该评论由网站上的主持人最小化
抱歉,Harsh,请注意避免重复导入。
该评论由网站上的主持人最小化
嗨,我想防止在 excel 中删除前面的零。

我试过下面的代码,但它不工作


子测试()
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
暗淡 j 只要
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
设置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那么
对于 I = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" '这是在粘贴文本文件数据之前将excel做成文本格式
xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)
出错时继续下一步
ActiveSheet.Name = xWb.Name
出错时转到 0
xWb.Close 错误
下一页
结束如果
END SUB
该评论由网站上的主持人最小化
Pooja,您可以尝试 Kutools for Excel 的删除前导零功能,以在导入后从选择中删除所有前导零。
查看附件 (1 / 5)
该评论由网站上的主持人最小化
但我不想删除。 我想防止删除前面的零。
该评论由网站上的主持人最小化
如果要保留前导零,可以通过 Cell Format 将它们格式化为文本格式。
该评论由网站上的主持人最小化
您好,请问如何修改这段代码插入*.txt文件的顺序:1,2,3,4,5,6,7,8,9,10,11、1,10,11,12,13,14,15,16,17,18,19,2,20,21、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX等。目前代码插入文件如下:XNUMX、 XNUMX 等。谢谢!
该评论由网站上的主持人最小化
是否有机会仅从 txt 文件名中获取工作表名称的某些部分?

根据上面的代码,整个工作表名称一直在使用。
该评论由网站上的主持人最小化
非常感谢 Office 2007 excel 上的工作
该评论由网站上的主持人最小化
嗨,我的代码运行但只导入第一个文件。 它说复制有一个方法错误。 调试器突出显示以下代码行。 有任何想法吗?


xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)
该评论由网站上的主持人最小化
嘿马蒂尼奥,
我遇到了同样的问题并通过更改此行来解决它:
设置 xToBook = ThisWorkbook

设置 xToBook = ActiveWorkbook
也许这有帮助。
该评论由网站上的主持人最小化
0

我需要你帮助我不知道 vba excel 我想导入多个文本文件,例如 13000。文本文件名与单元格相同,例如(c1=112 所以文本文件名也是 112)意味着文本文件 112 是进口c112。
该评论由网站上的主持人最小化
我需要你帮助我不知道 vba excel 我想导入多个文本文件,例如 13000。文本文件名与单元格相同,例如(c1=112 所以文本文件名也是 112)意味着文本文件 112 是进口c112。
该评论由网站上的主持人最小化
该代码有效,但将每个文本文件导入工作簿中的新选项卡。 知道在代码中的哪个位置可以更改以在上一个文本文件的数据下方的同一工作表上导入新的文本文件吗?
该评论由网站上的主持人最小化
在下面的代码中,如果我想指定文件夹而不是每次导入文本文件时都选择路径,则必须进行哪些修改

VBA代码:

子 ImportCSVsWithReference()
'更新由 KutoolsforExcel20151214
将 xSht 调暗为工作表
将 xWb 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
出错时转到 ErrHandler
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
设置 xSht = ThisWorkbook.ActiveSheet
If MsgBox("导入前清除现有工作表?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
执行 xFile <> ""
设置 xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close 错误
xFile = 目录
循环
Application.ScreenUpdating =真
退出小组
错误处理程序:
MsgBox "没有 txt 文件", , "Kutools for Excel"
END SUB
该评论由网站上的主持人最小化
你好,试试下面的代码
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

“C:\Users\AddinsVM001\Desktop\test”是您可以从中导入文本文件的文件夹路径,请根据需要进行更改。
该评论由网站上的主持人最小化
您好,感谢您提供宝贵的 VBA 代码。
但是,我需要将多个 txt 文件的代码转换为“工作表中的单个工作表,而不是每个 txt 文件的单个工作表”。
为了我的目的,我应该如何编辑您的代码?

谢谢,
该评论由网站上的主持人最小化
你好,试试下面的代码
Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
该评论由网站上的主持人最小化
这很好用。 但是当它导入时它用 name.txt 重命名工作表如何让它只保留名称而不向工作表添加 .txt 扩展名?
3.5中的5评分
该评论由网站上的主持人最小化
好的 nvm 在谷歌帮助下找到了答案。
替换线:
ActiveSheet.Name = xWb.Name
使用:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
将从工作表名称中删除最后 4 个字母。 有效地给了我我需要的东西。 不带 .txt 的名称
干杯
4中的5评分
该评论由网站上的主持人最小化
在将文本文件导入工作表时,以下代码可以根据空格或制表符将数据拆分为列。 但我不希望每个 txt 文件都有一个单独的选项卡,我希望它们都在一张纸下。 每个文件的信息格式相同。 . 可以修改什么以允许这全部是一张纸而不是每个导入的文件都是一个新选项卡任何和所有帮助将不胜感激

子 ImportTextToExcel()
'更新通过Extendoffice20180911
将 xWb 调暗为工作簿
将 xToBook 调暗为工作簿
将 xStrPath 调暗为字符串
将 xFileDialog 调暗为 FileDialog
将 xFile 调暗为字符串
将 xFiles 调暗为新集合
暗淡我只要
将 xIntRow 变暗
暗淡 xFNum, xFArr 只要
将 xStrValue 调暗为字符串
将 xRg 调暗为范围
暗淡 xArr
设置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "选择一个文件夹 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那么
xStrPath = xFileDialog.SelectedItems(1)
结束如果
如果 xStrPath = "" 则退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那么
MsgBox "没有找到文件", vbInformation, "Kutools for Excel"
退出小组
结束如果
执行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目录()
循环
设置 xToBook = ThisWorkbook
出错时继续下一步
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那么

对于 I = 1 到 xFiles.Count
设置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).复制之后:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 错误
xIntRow = ActiveCell.CurrentRegion.Rows.Count
对于 xFNum = 1 到 xIntRow
设置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那么
对于 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那么
xRg.Value = xArr(xFArr)
设置 xRg = xRg.Offset(ColumnOffset:=1)
结束如果
下一页
结束如果
下一页
下一页
结束如果
Application.ScreenUpdating =真
END SUB
该评论由网站上的主持人最小化
嗨,丹尼尔,试试下面的代码,它将所有文本文件导入一个名为 Txt 的工作表中。
注意:如果文本名称与现有工作表名称相同,则可能无法导入文本文件。
Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub


这里还没有评论
留下你的意见
以访客身份发帖
×
评价此帖子:
0   产品特性
建议地点

关注我们

版权所有 © 2009 - extendoffice.com。 | 版权所有。 供电 ExtendOffice。 | 网站地图
Microsoft和Office徽标是Microsoft Corporation在美国和/或其他国家的商标或注册商标。
受Sectigo SSL保护