如何用VBA将多个文档的信息汇总到一个文档？

lwair · 发表于 2007-1-18 15:08

如何用VBA将多个文档里的信息汇总到另一个文档中？

即将附件的00.doc和01.doc中的规档时间、作者、页码等信息汇总到汇总.doc中。

14Wv6pbT.rar (29.68 KB, 下载次数: 53)

[此贴子已经被作者于2007-1-18 17:45:43编辑过]

守柔 · 发表于 2007-1-18 19:49

请楼主回答我几个问题:

1,你的标题样式是否固定为"标题1"?

2,你的所有文档是否都有目录,并且目录为第一节?

3,你的所有为"标题1"的内容是否均只有独立的一节?

4,你的"标题1"下面的作者,是否为不确定性,如有空一个段落,有空两个段落或者N个空白段落的?

5,汇总文档中的表格是否直接使用代码生成?

6,如果你需要的汇总文档不止2个,是否有先后的顺序名,或者无论先后?

其他您认为需要交待的事宜,请一并说清楚,谢谢.

[此贴子已经被作者于2007-1-18 19:50:56编辑过]

lwair · 发表于 2007-1-18 21:39

谢谢斑竹的答复，问题回答如下：

1,你的标题样式是否固定为"标题1"?

答：是。

2,你的所有文档是否都有目录,并且目录为第一节?

答：是。

3,你的所有为"标题1"的内容是否均只有独立的一节?

答：不一定，有可能有多个节。

4,你的"标题1"下面的作者,是否为不确定性,如有空一个段落,有空两个段落或者N个空白段落的?

答：一个空段落（我以后保持统一）。

5,汇总文档中的表格是否直接使用代码生成?

答：直接用代码生成，对框线和字体等没有要求。

6,如果你需要的汇总文档不止2个,是否有先后的顺序名,或者无论先后?

答：需要排序。

7.我修改一下汇总表，加入了一个截稿时间，在汇总表中增加了一列。如果归档时间早于截稿时间，显示“P”，否则显示“O”。

谢谢了！

9vK8w9RW.rar (30.34 KB, 下载次数: 28)

[此贴子已经被作者于2007-1-18 21:41:46编辑过]

守柔 · 发表于 2007-1-20 08:35

挺累的,以下代码供参考:

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-1-20 8:33:52
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0139^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Dim GetNumber() As String, GetDate() As String, GetAuthor() As String, GetTitle() As String
Dim myDate As String
Sub Total()
    Dim myDialog As FileDialog, oDoc As Document, myPar As Paragraph
    Dim A As Variant, myTable As Table, myRow As Row, myRange As Range
    Dim myArray() As String, N As Integer, KeyArray() As Integer
    Dim FolderPath As String, KeyValue As Integer, M As Byte
    Dim I As Integer, J As Integer, Temp As String, TempA As String
    myDate = VBA.InputBox(prompt:="请正确输入截稿日期!" & vbCrLf & "例如:2007-1-20 或者 2007/1/20", _
                          Title:="ExcelHome_ShouRou", Default:=VBA.Format(Now, "YYYY-M-D"))
    If myDate = "" Then Exit Sub
    With Me
        .Content.Delete
        .Content.InsertAfter "汇总表" & Chr(13)
        .Content.InsertAfter "截稿日期：" & myDate
    End With
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件

守柔 · 发表于 2007-1-20 08:36

        .AllowMultiSelect = True    '允许多项选择
        If .Show <> -1 Then Exit Sub
        FolderPath = .InitialFileName    '取得文件夹位置
        For Each A In .SelectedItems     '在所有选取项目中循环
            ReDim Preserve myArray(N)    '扩展数组
            ReDim Preserve KeyArray(N)    '扩展数组
            myArray(N) = A    '项目全路径
            '取得关键字的数值,如果不包含数据,则可能为0
            KeyValue = VBA.Val(VBA.Replace(A, FolderPath, ""))
            KeyArray(N) = KeyValue
            N = N + 1    '累加
        Next
    End With
    Set myDialog = Nothing    '释放对象变量
    N = N - 1    '恢复N值(数组上标)
    For I = 0 To N - 1   '在数组中循环取值
        For J = I + 1 To N    '冒泡法排序
            If KeyArray(I) > KeyArray(J) Then
                Temp = KeyArray(J)
                TempA = myArray(J)
                KeyArray(J) = KeyArray(I)
                myArray(J) = myArray(I)
                KeyArray(I) = Temp
                myArray(I) = TempA
            End If
        Next J
    Next I
    Application.ScreenUpdating = False

守柔 · 发表于 2007-1-20 08:37

    For Each A In myArray
        Set oDoc = Documents.Open(FileName:=A, Visible:=False)
        With oDoc
            If Me.Tables.Count = 0 Then
                AddRow(1).Cells(1).Range.Text = GetSubject(oDoc)
            Else
                AddRow(3).Cells(1).Range.Text = GetSubject(oDoc)
            End If
            Call GetInformation(oDoc)
            For M = 0 To UBound(GetNumber)
                With AddRow(2)
                    If CDate(GetDate(M)) < CDate(myDate) Then
                        .Cells(1).Range.Text = "√"
                    Else
                        .Cells(1).Range.Text = "×"
                    End If
                    .Cells(2).Range.Text = GetTitle(M)
                    .Cells(3).Range.Text = GetNumber(M)
                    .Cells(4).Range.Text = GetDate(M)
                    .Cells(5).Range.Text = GetAuthor(M)
                End With
            Next
            .Close False
        End With
    Next
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandle:
    Application.ScreenUpdating = True
    MsgBox "错误:" & Err.Number & vbCrLf & "出错原因: " & Err.Description, vbExclamation, "ExcelHome_ShouRou"
    Err.Clear
End Sub
'----------------------

守柔 · 发表于 2007-1-20 08:37

Function GetSubject(Doc As Document) As String
    Dim myRange As Range
    With Doc
        Set myRange = .Range(0, .TablesOfContents(1).Range.Start)
        GetSubject = VBA.Replace(myRange.Text, " ", "")
        GetSubject = VBA.Replace(GetSubject, Chr(13), "")
        GetSubject = VBA.Replace(GetSubject, "目录", "")
    End With
End Function
'----------------------
Function AddRow(M As Byte) As Row
    Dim myRange As Range, I As Byte, myArray1 As Variant, myArray2 As Variant, myRow As Row
    Dim ThisTable As Table
    myArray1 = Array(1.14, 4.44, 2.7, 3.57, 3.57)
    myArray2 = Array("标题", "页码", "规档日期", "作者")
    With Me
        Select Case M
        Case 1
            .Content.InsertAfter Chr(13)
            Set myRange = .Range(.Content.End - 1, .Content.End - 1)
            Set ThisTable = Me.Tables.Add(myRange, 2, 5)
            With ThisTable
                .Style = "网格型"
                For I = 1 To 5
                    .Columns(I).Width = Word.CentimetersToPoints(myArray1(I - 1))
                Next
                Set myRow = .Rows(2)
                For I = 2 To 5
                    myRow.Cells(I).Range.Text = myArray2(I - 2)
                Next
                .Rows(1).Cells.Merge
                Set AddRow = .Rows.First
            End With
        Case 2
            Set ThisTable = .Tables(1)
            With ThisTable
                Set myRow = .Rows.Last
                myRow.Select

守柔 · 发表于 2007-1-20 08:38

                Me.ActiveWindow.Selection.InsertRowsBelow 1
                Set AddRow = .Rows.Last
            End With
        Case 3
            Set ThisTable = .Tables(1)
            With ThisTable
                Set myRange = Me.Range(.Rows(.Rows.Count - 1).Range.Start, .Rows.Last.Range.End)
                myRange.Rows.Select
                Me.ActiveWindow.Selection.InsertRowsBelow 2
                Set myRow = .Rows.Last
                For I = 2 To 5
                    myRow.Cells(I).Range.Text = myArray2(I - 2)
                Next
                .Rows(.Rows.Count - 1).Cells.Merge
                Set AddRow = .Rows(.Rows.Count - 1)
            End With
        End Select
    End With
End Function
'----------------------
Sub GetInformation(oDoc As Document)
    Dim I As Field, myBook() As String, N As Byte, myPage() As String
    Dim EndRange As Range, Temp() As String, myRange As Range
    N = 0
    Erase myPage
    Erase myBook
    Erase Temp
    Erase GetTitle
    Erase GetNumber
    Erase GetDate
    Erase GetAuthor
    With oDoc
        For Each I In .TablesOfContents(1).Range.Fields
            If I.Type = wdFieldPageRef Then
                ReDim Preserve myBook(N)
                ReDim Preserve myPage(N)
                myBook(N) = VBA.Replace(I.Code.Text, " PAGEREF ", "")
                myBook(N) = VBA.Replace(myBook(N), " \h ", "")
                myPage(N) = I.Result
                If N = 0 Then myPage(N) = I.Result Else myPage(N - 1) = myPage(N - 1) & "-" & I.Result - 1

守柔 · 发表于 2007-1-20 08:39

                N = N + 1
            End If
        Next
        N = N - 1
        Set EndRange = .Range(.Content.End - 1, .Content.End - 1)
        myPage(N) = myPage(N) & "-" & EndRange.Information(wdActiveEndAdjustedPageNumber)
        ReDim GetTitle(N)
        ReDim GetNumber(N)
        ReDim GetDate(N)
        ReDim GetAuthor(N)
        For N = 0 To UBound(myBook)
            Debug.Print myBook(N), myPage(N)
            Set myRange = .Bookmarks(myBook(N)).Range.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 2).Range
            myRange.SetRange myRange.Start, myRange.End - 1
            GetDate(N) = VBA.Replace(VBA.Replace(myRange.Text, " ", ""), "规档日期：", "")
            Set myRange = .Bookmarks(myBook(N)).Range
            '            myRange.SetRange myRange.Start, myRange.End - 1
            GetTitle(N) = myRange.Text
            Set myRange = .Bookmarks(myBook(N)).Range.Paragraphs(1).Next(2).Range
            myRange.SetRange myRange.Start, myRange.End - 1
            GetAuthor(N) = myRange.Text
            Temp = VBA.Split(myPage(N), "-")
            If Temp(0) = Temp(1) Then
                GetNumber(N) = "第" & Temp(0) & "页"
            Else
                GetNumber(N) = "第" & myPage(N) & "页"
            End If
        Next
        '        For N = 0 To UBound(GetNumber)
        '            Debug.Print GetNumber(N), GetDate(N), GetAuthor(N), GetTitle(N)
        '        Next
    End With
End Sub
'----------------------

守柔 · 发表于 2007-1-20 08:40

'Sub Test()
'    Call GetInformation(ActiveDocument)
'End Sub
'Sub E()
'myDate = VBA.InputBox(prompt:="请正确输入截稿日期!" & vbCrLf & "例如:2007-1-20 或者 2007/1/20", Title:="ExcelHome_ShouRou")
'    If myDate = "" Then Exit Sub
'    MsgBox CDate(myDate)
'End Sub

成品见附件:

WaIFsOUu.rar (16.07 KB, 下载次数: 99)

		自动登录	找回密码
密码			免费注册