把发文稿纸中的内容提取到发文登记簿中？

4me

是把发文稿.doc和发文登记簿.xls放一起。发文登记簿里看到的是导入的结果。

[ 本帖最后由 4me 于 2009-11-2 14:59 编辑 ]

ke3088

我知道您的意思了，还是太麻烦了。我的想法是在发文稿纸里拟好文稿、修改后，直接运行发文稿纸里的宏就OK，自动生成发文登记簿里的数据。谢谢您！

4me

自己移植代码到word再修改，就行了。

ke3088

您的代码是用在EXCEL的，移植在WORD里用，不能识别

4me

要学会借用修改。

ke3088

对我也想学好VBA，目前还靠大家

sylun

可以试试如下代码，忽略保存位置的判断与添加等问题：

Sub GetInfo()
    Dim myArray As Variant, i As Byte, a As String, info As String
    Dim AppExcel As Object, WkBook As Object, r As Long
    myArray = Array(10, 14, 16, 2, 24, 30)  '主要单元格的索引号
    With ActiveDocument
        With .Content.Find  '查找并提取发文日期
            .Text = "^13????年[一-龥]@月[一-龥]@日^13"
            .MatchWildcards = True
            If .Execute Then
                If .Parent.Paragraphs(2).Alignment = wdAlignParagraphRight Then
                    info = Replace(.Parent, Chr(13), "")
                    If IsDate(info) = False Then info = Replace(.Parent, "〇", "○")
                    info = Format(info, "General Date")
                Else
                    MsgBox "没有找到右缩进的发文日期！"
                    Exit Sub
                End If
            Else
                MsgBox "没有找到合适的发文日期！"
                Exit Sub
            End If
        End With
        With .Tables(1).Range  '提取表格中的主要项目
            For i = 0 To UBound(myArray)
                a = Replace(.Cells(myArray(i)).Range, Chr(13) & Chr(7), "")
                a = Trim(a)
                If a = "" Then
                    MsgBox "表格中的主要项目有漏填！"
                    Exit Sub
                Else
                    info = info & "|" & a
                End If
            Next
        End With
    End With
   
    '数据写入excel文档
    Set AppExcel = CreateObject("Excel.Application")
    AppExcel.Visible = True
    Set WkBook = AppExcel.Workbooks.Open(ActiveDocument.Path & "\发文登记簿(模板).xls")  '暂设excel文档与发文稿保存在同一目录下
    WkBook.Sheets(1).Activate
    With WkBook.ActiveSheet
        r = .Range("b2:b65536").End(-4121).Row + 1
        .Cells(r, 1).Formula = "=row() - 2"
        For i = 2 To 8
            .Cells(r, i).Value = Split(info, "|")(i - 2)
        Next
        .Range(.Cells(r, 1), .Cells(r, 8)).Borders.LineStyle = 1
    End With
    WkBook.Close True
    AppExcel.Quit
    Set AppExcel = Nothing
    MsgBox "数据已成功提取！"
End Sub

4me

同时打开，word里执行
发文.rar (32 KB, 下载次数: 63)

2009-11-3 09:10 上传

点击文件名下载附件

ke3088

sylun兄，谢谢您！运行代码后，可以打开发文登记簿(模板).xls，在.Cells(r, 1).Formula = "=row() - 2"处，但出现以下错误“运行时错误'1004'   应用程序错误定义或对象定义错误”，我也给工具—引用中的EXCEL 11.0前面打勾了。不好意思，再麻烦您看看，是什么原因？致以衷心感谢！
4me兄，谢谢您！更改落款日期格式也不是不可以，但我还觉得使用常规方式比较妥，毕竟公文起草还是要求严谨些为好。不过，还是衷心感谢您的帮助！

[ 本帖最后由 ke3088 于 2009-11-3 13:09 编辑 ]

sylun

原帖由 ke3088 于 2009-11-3 13:08 发表
sylun兄，谢谢您！运行代码后，可以打开发文登记簿(模板).xls，在.Cells(r, 1).Formula = "=row() - 2"处，但出现以下错误“运行时错误'1004'   应用程序错误定义或对象定义错误”，我也给工具—引用中的EXCEL 11.0前 ...

原来是其前一句的问题，但我昨晚在家测试时是可以通过的。请将其前一行代码改为如下代码再试试（无需引用EXCEL对象库）：
r = .Range("a1:b65536").End(-4121).Row + 1
或者
r = .UsedRange.Rows.Count + 1

程序也可以判断将要记录的数据是否有重复（比如以文号为依据），或者在发现漏填时选定漏填位置，这样也许更完整些。