请教WORD多行数值如何用宏汇总转到文本框内？

上传了1个范例结算单和1个范例产值卡

请教如何做到WORD范例结算单内一项工程有多行结算数值的如何用宏汇总转到WORD范例产值卡的文本框内？而且要做到自动转换为中文货币大写，还要做到不管每项工程内容的文本有多少文字只能输入到范例产值卡的一页内？

这一项功能对我来说很重要，请版主帮帮小弟，衷心感谢！

具体如下：
项 目     工    程     内   容        单位     数量       单   价      小  计
ITEM     DESCRIPTION                  UNIT     QUTY        U-PRICE     AMOUNT

1    1仓前过道甲板纵梁    
      球扁钢18*620*1件               件          1         360.00      360.00
      球扁钢18*500*1件               件          1         360.00      360.00
     球扁钢18*650*1件                件          1         360.00      360.00
     球扁钢18*770*1件                件          1         360.00      360.00
     球扁钢18*600*1件                件          1         360.00      360.00
     球扁钢18*700*1件                件          1         360.00      360.00
     应急消防泵门口底板挖换    
     δ10*1000*1000*1件               KG       78.50        12.30       965.55
     附带割换壁板    
     δ8*200*1200*2件                 件          2         720.00      1440.00
     拆装踏板    
     δ6*350*600*1件                  KG        9.89        10.80       106.81

需要把范例结算单小计部分汇总输入到范例产值卡新插入的文本框内（文本框边界要透明），要做到自动转换为中文货币大写，不管每项工程内容的文本有多少文字只能输入到范例产值卡的一页内，范例产值卡的要达到的效果请看附件。

点击浏览该文件
点击浏览该文件

没看明白.

估计用到:

表格转文本,函数sumabove(),录制宏

老大，帮帮忙阿，其实最重要的是实现数据统计并转到另一文档的文本框中，每页代表一项工程

用二个小时给楼主做了一个示范，希望能对你有所帮助，我最近很忙，注意你的发贴求助方式。

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-9-28 6:22:57
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0263^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Dim EndRange As Range
Sub GetJSD()
    Dim JSDDoc As Document, myDialog As FileDialog, JSDTable As Table, oCell As Cell
    Dim myRange As Range, lngStart As Long, lngEnd As Long
    On Error Resume Next
    Set myDialog = Application.FileDialog(msoFileDialogOpen)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        Set JSDDoc = Word.Documents.Open(FileName:=.SelectedItems(1), Visible:=False)
        Set myDialog = Nothing
    End With
    Set JSDTable = JSDDoc.Tables(3)
    For Each oCell In JSDTable.Columns(1).Cells
        If oCell.Range.Text Like "#*" Then
            If myRange Is Nothing Then
                Set myRange = oCell.Range
                lngStart = oCell.Range.Start
                myRange.SetRange lngStart, lngStart
            Else
                lngStart = oCell.Range.Start
                myRange.SetRange myRange.End, lngStart
                myFunction myRange
                EndRange.InsertAfter Chr(12) & Chr(13)
            End If
        End If
    Next
    myRange.SetRange myRange.End, JSDTable.Range.End
    myRange.Select
    Set EndRange = Me.Range(Me.Content.End - 1, Me.Content.End - 1)
    myFunction myRange
    JSDDoc.Close False
End Sub
'----------------------

Function myFunction(wdRange As Range)
    Dim myTable As Table, myTextBox As Shape
    Dim TextRange As Range, AnchorRange As Range, myField As Field
    Set EndRange = Me.Range(Me.Content.End - 1, Me.Content.End - 1)
    EndRange.FormattedText = wdRange.FormattedText
    Set myTable = EndRange.Tables(1)
    Me.Bookmarks.Add Name:="SUMTABLE", Range:=myTable.Range
    Set myTextBox = Me.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                         Left:=380, Top:=300, Width:=230, Height:=85, Anchor:=EndRange)
    myTextBox.Line.Visible = msoFalse
    Set TextRange = myTextBox.TextFrame.TextRange
    Set myField = TextRange.Fields.Add(TextRange, wdFieldEmpty, "=SUM(SUMTABLE F:F) \* CHINESENUM2", False)
    myField.Unlink
    TextRange.InsertBefore "产值" & Chr(13)
    TextRange.InsertAfter "圆整"
    Set EndRange = EndRange.Tables(1).ConvertToText(wdSeparateByTabs)
    With EndRange.Find
        .ClearFormatting
        .MatchWildcards = True
        .Execute FINDTEXT:="^t{5}^13", replacewith:="", Replace:=wdReplaceAll
    End With
    With EndRange.Font
        .Name = "华文细黑"
        .Size = 10
        .Bold = False
        .Color = wdColorBlack
    End With
End Function
'----------------------

见附件：

LN5neBvk.rar (16.19 KB)

[此贴子已经被作者于2007-9-28 6:29:56编辑过]

谢谢守柔百忙之中用宝贵的时间帮助小弟的困难，守柔是我见过的最好的版主，有超强能力却没有架子，再一次感谢！

守柔这一代码解决了我大部分问题，现在我测试过后发现小问题如下：

从结算单拷贝过来的内容超出了产值卡的右边距，我只需要拷贝结算单的第1列和第2列到产值卡，那么代码做如何修改？

比如第二项工程内容有很多行，我需要在VBA里面判断如果一项工程占了几页就设置这一段内容的字体为小五号然后设置这一段内容的行距的磅值为零磅，如果还是一项工程占了几页就删除所有空格和回车以达到效果，请帮我修改一下代码好吗？

插入文本框内的字体太小，我想设置文本框内的文本字体大小为“小四”，怎么加代码？

另外一个重要的问题就是我不想把代码放在 [ThisDocument-ThisDocument]^中，因为这样只能每个产值卡都要有这段宏代码才能运行,我想在模块中实现这些功能（这样做的好处就是只需要做一个宏模板放在STARUP文件夹下就可以操作所有的文档），怎样改代码呢？

[此贴子已经被作者于2007-9-28 16:34:56编辑过]

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-9-29 6:03:00
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0264^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Dim EndRange As Range, CZKDoc As Document
Sub GetJSD()
    Dim JSDDoc As Document
    Dim myDialog As FileDialog, JSDTable As Table, oCell As Cell
    Dim myRange As Range, lngStart As Long, lngEnd As Long
    On Error Resume Next '忽略错误
    Set myDialog = Application.FileDialog(msoFileDialogOpen)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = False
        .Title = "请选择一个产值卡文档"
        If .Show <> -1 Then Exit Sub
        Set CZKDoc = Word.Documents.Open(FileName:=.SelectedItems(1))
    End With
       With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = False
        .Title = "请选择一个结算卡文档"
        If .Show <> -1 Then Exit Sub
        Set JSDDoc = Word.Documents.Open(FileName:=.SelectedItems(1), Visible:=False)
        Set myDialog = Nothing
    End With
  

Application.ScreenUpdating = False '关闭屏幕更新
    Set JSDTable = JSDDoc.Tables(3) '定义一个表格对象为结算单中的第三个表格
    For Each oCell In JSDTable.Columns(1).Cells '在表格第1列中循环
        If oCell.Range.Text Like "#*" Then
            If myRange Is Nothing Then
                Set myRange = oCell.Range
                lngStart = oCell.Range.Start
                myRange.SetRange lngStart, lngStart
            Else
                lngStart = oCell.Range.Start
                myRange.SetRange myRange.End, lngStart
                myFunction myRange
                EndRange.InsertAfter Chr(12) & Chr(13) '插入分页符
            End If
        End If
    Next
    myRange.SetRange myRange.End, JSDTable.Range.End
    myFunction myRange
    JSDDoc.Close False '关闭结算单文档
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub

'----------------------
Function myFunction(wdRange As Range)
    Dim myTable As Table, myTextBox As Shape, myBK As Bookmark
    Dim TextRange As Range, myField As Field
    Dim RngStart As Range, RngEnd As Range
    Dim intPageStart As Integer, intPageEnd As Integer
    Dim sinFS As Single
    Set EndRange = CZKDoc.Range(CZKDoc.Content.End - 1, CZKDoc.Content.End - 1)
    EndRange.FormattedText = wdRange.FormattedText    '将格式文本'复制'到指定区域
    Set myTable = EndRange.Tables(1)    '定义一个表格对象
    '设置一个书签,有效利用Word域对于表格的求和
    Set myBK = CZKDoc.Bookmarks.Add(Name:="SUMTABLE", Range:=myTable.Range)
    '定义一个文本框的Shape对象
    Set myTextBox = CZKDoc.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                         Left:=380, Top:=300, Width:=230, Height:=55, Anchor:=EndRange)
    myTextBox.Line.Visible = msoFalse    '无线条颜色

    Set TextRange = myTextBox.TextFrame.TextRange    '定义一个RANGE对象
    '文本框中插入一个域,其结果为第6列求和后的中文大写
    Set myField = TextRange.Fields.Add(TextRange, wdFieldEmpty, "=SUM(SUMTABLE F:F) \* CHINESENUM2", False)
    myField.Unlink    '切断域链接
    With TextRange
        .InsertBefore "产值" & Chr(13)    '在数据前插入"产值"后换行
        .InsertAfter "圆整"    '在数据后插入"圆整"
        .Font.Size = 12
        .Font.Name = "华文细黑"
    End With
    '删除3-6列
    myTable.Columns(6).Delete
    myTable.Columns(5).Delete
    myTable.Columns(4).Delete
    myTable.Columns(3).Delete
    '以制表位为分隔符将表格转换为文本
    myTable.ConvertToText wdSeparateByTabs
    '查找法删除表格转换后的空行
    With myBK.Range.Find
        .ClearFormatting
        .MatchWildcards = True
        .Execute findtext:="^t^13", replacewith:="", Replace:=wdReplaceAll
    End With

With myBK.Range.Font
        .Name = "华文细黑"
        .Size = 10
        .Bold = False
        .Color = wdColorBlack
    End With
    '进入缩减循环
    sinFS = 10
    Do
        With myBK
            Set RngStart = .Range    '定义一个RANGE对象
            '其值为书签起始处位置
            RngStart.SetRange RngStart.Start, RngStart.Start
            '取得起始页码
            intPageStart = RngStart.Information(wdActiveEndPageNumber)
            Set RngEnd = .Range    '定义一个RANGE对象
            '其值为书签结束处位置
            RngEnd.SetRange RngEnd.End, RngEnd.End
            '取得结束页码
            intPageEnd = RngEnd.Information(wdActiveEndPageNumber)
            '如果在同一页则退出循环
            If intPageStart = intPageEnd Then Exit Do
            '/////////////////////////////////////
            '段前段后间距为0
            .Range.ParagraphFormat.SpaceAfter = 0
            .Range.ParagraphFormat.SpaceBefore = 0
            Set RngStart = .Range    '定义一个RANGE对象
            '其值为书签起始处位置
            RngStart.SetRange RngStart.Start, RngStart.Start

            '取得起始页码
            intPageStart = RngStart.Information(wdActiveEndPageNumber)
            Set RngEnd = .Range    '定义一个RANGE对象
            '其值为书签结束处位置
            RngEnd.SetRange RngEnd.End, RngEnd.End
            '取得结束页码
            intPageEnd = RngEnd.Information(wdActiveEndPageNumber)
            '如果在同一页则退出
            If intPageStart = intPageEnd Then Exit Do
            '//////////////////////////////////////
            sinFS = sinFS - 1
            .Range.Font.Size = sinFS
            Set RngStart = .Range    '定义一个RANGE对象
            '其值为书签起始处位置
            RngStart.SetRange RngStart.Start, RngStart.Start
            '取得起始页码
            intPageStart = RngStart.Information(wdActiveEndPageNumber)
            Set RngEnd = .Range    '定义一个RANGE对象
            '其值为书签结束处位置
            RngEnd.SetRange RngEnd.End, RngEnd.End
            '取得结束页码
            intPageEnd = RngEnd.Information(wdActiveEndPageNumber)
            If intPageStart = intPageEnd Then Exit Do
         

   '/////////////////////////////////////
            '删除制表位,将段落标记替换为全角空格
            .Range.Find.Execute findtext:="^t", replacewith:="", Replace:=wdReplaceAll
            .Range.Find.Execute findtext:="^13", MatchWildcards:=False, replacewith:="　", Replace:=wdReplaceAll
            Set RngStart = .Range    '定义一个RANGE对象
            '其值为书签起始处位置
            RngStart.SetRange RngStart.Start, RngStart.Start
            '取得起始页码
            intPageStart = RngStart.Information(wdActiveEndPageNumber)
            Set RngEnd = .Range    '定义一个RANGE对象
            '其值为书签结束处位置
            RngEnd.SetRange RngEnd.End, RngEnd.End
            '取得结束页码
            intPageEnd = RngEnd.Information(wdActiveEndPageNumber)
            If intPageStart = intPageEnd Then Exit Do
        End With
    Loop
End Function
'----------------------

附件若另存为模板，可直接作为加载宏，请为其自定义一个命令，或者ALT+F8，运行加载项中的宏即可。

0P0VITxw.rar (18.1 KB)

[此贴子已经被作者于2007-9-29 6:16:23编辑过]

[em17]守柔老大，你是最棒的，很感谢这么费心为我解决问题，这一段代码已经完美解决我的问题，非常好用！我一定好好学习VBA，希望我得到老大的“鱼”之后能学会老大的“渔”并帮助需要的人，在这个论坛我感受到了温暖，不是用语言可以表达的。谢谢守柔！

好东西 ，分享了