请老师们帮帮忙，WORD利用VBA按文本序号导入文本

yjwdjfqb

请老师们帮帮忙，在WORD利用VBA按文本序号导入文本
如图：
将当前路径下，所有文本导入到WORD文档中，导入的顺序按文本文件名的序号，顺序导入：

谢谢老师们了，老师们帮帮忙！
WORD利用VBA按文本序号导入文本.rar (6.07 KB, 下载次数: 33)

2015-10-27 23:30 上传

点击文件名下载附件

liuhoubin168

Sub 依次读文本()
     Dim fs1, f1
     Set fs1 = CreateObject("Scripting.FileSystemObject")
     For i = 1 To 4
       file1 = "E:\桌面\WORD利用VBA按文本序号导入文本\" & i & ".文本.txt"
       Set f1 = fs1.OpenTextFile(file1, 1, 0)
       Selection.TypeText f1.Readall
       Selection.TypeParagraph
       f1.Close
     Next i
     Set f1 = Nothing
     Set fs1 = Nothing
End Sub

413191246se

楼主标题挺吓人，其实就是批量合并。——楼上代码很不错，就是变量未定义。
我给楼主提供一个《批量合并》宏：

1. Sub 循环遍历文件夹_批量合并()
   
2.     On Error Resume Next
   
3.     Dim fd As FileDialog, i As Long, doc As Document, p As String, t As Long, s As Long
   
4.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
5.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
   
6.     Set fd = Nothing
   
7.     If MsgBox("是否合并文件夹 " & p & " ?", vbYesNo + vbExclamation, "循环遍历文件夹_批量合并") = vbNo Then Exit Sub
   
8.     If MsgBox("是否合并 Word 文档(*.doc)？（否则合并文本文档(*.txt)）", vbYesNo + vbExclamation, "循环遍历文件夹_批量合并") = vbYes Then t = 0 Else t = 1
   
9.     If MsgBox("合并文档之间是否插入分页符？", vbYesNo + vbExclamation, "循环遍历文件夹_批量合并") = vbYes Then s = 1 Else s = 0
   
10.     Documents.Add
    
11.     With Application.FileSearch
    
12.         .NewSearch
    
13.         .LookIn = p
    
14.         .SearchSubFolders = True
    
15.         If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
    
16.         If .Execute > 0 Then
    
17.             For i = 1 To .FoundFiles.Count
    
18.                 If t = 0 Then Set doc = Documents.Open(FileName:=.FoundFiles(i)) Else Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936)
    
19.                 doc.Content.Copy
    
20.                 doc.Close
    
21.                 Selection.EndKey Unit:=wdStory
    
22.                 Selection.Paste
    
23.                 ActiveDocument.Characters(1).Copy
    
24.                 If s = 1 Then Selection.InsertBreak Type:=wdPageBreak
    
25.             Next i
    
26.             If s = 1 Then Selection.TypeBackspace: Selection.TypeBackspace Else Selection.TypeBackspace
    
27.             MsgBox "合并完毕！共合并 " & .FoundFiles.Count & " 个文件！文档尚未保存，请自行保存！", vbOKOnly + vbExclamation, "循环遍历文件夹_批量合并"
    
28.         Else
    
29.             MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_批量合并"
    
30.         End If
    
31.     End With
    
32. End Sub

复制代码

yjwdjfqb

liuhoubin168 发表于 2015-10-28 09:57
Sub 依次读文本()
     Dim fs1, f1
     Set fs1 = CreateObject("Scripting.FileSystemObject")

谢谢老师的帮助，今天有事没有上电脑看，现在回来才看到。
就是要这样的效果

老师可否再帮我修改下：
1、合并的文本文件数不固定4个
2、不固定合并文本文件的路径，使用对话框进行选择，可以任意选择几个合并。
3、文件名不固定（只要保证文本文件开头是数字就行如：1.测试　2.效果　3.总结　4.分析　）这样。
请老师帮帮我修改下，谢谢你了老师！

yjwdjfqb

413191246se 发表于 2015-10-28 10:29
楼主标题挺吓人，其实就是批量合并。——楼上代码很不错，就是变量未定义。
我给楼主提供一个《批量合并》 ...

老师你好，我试了下，没有成功，老师可以把你测试好的附件发个给我好吧，谢谢你了老师！

liuhoubin168

Sub 依次读文本()
      Dim fs1, f1
      Set fs1 = CreateObject("Scripting.FileSystemObject")
      文本文件路径="你的路径"   '比如"E:\桌面\WORD利用VBA按文本序号导入文本\"
      文本文件个数=4
      For i = 1 To 文本文件个数
        file1 = 文本文件路径 & i & ".文本.txt"
        Set f1 = fs1.OpenTextFile(file1, 1, 0)
        Selection.TypeText f1.Readall
        Selection.TypeParagraph
        f1.Close
      Next i
      Set f1 = Nothing
      Set fs1 = Nothing
End Sub

413191246se

请楼主先试试楼上代码吧，我的代码没有问题，附件免了，建议你重新测试，进入文件夹时要双击。

yjwdjfqb

liuhoubin168 发表于 2015-11-2 09:03
Sub 依次读文本()
      Dim fs1, f1
      Set fs1 = CreateObject("Scripting.FileSystemObject")

谢谢老师了！

kqbt

yjwdjfqb 发表于 2015-10-28 20:16
老师你好，我试了下，没有成功，老师可以把你测试好的附件发个给我好吧，谢谢你了老师！

3楼代码在2003版本下试试，注意弹窗对话框的选择。2007以上版本似乎没有了 Applicationo.FileSearch。
7楼测试结果正常。