[已解决]谁是牛人，欢迎来看看，试试手？

1261181315a

现有一组基站数据（含各种因素如A、B、C等），分列在WORD的若干表格（表格样式基本一致）中，现需要统计各基站各因素的最大值和最小值。把统计出来的值写入新的文件夹诸如EXCEL中。如下图中表一：红色代表各因素的最小值，土色代表最大值；表二中红色代表各因素最小值，土色代表最大值。如何找出以上数据并写入新的文件夹中？？？？

最佳答案

月排行榜 / 总排行榜

dsmch

2015-5-22 18:20

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim i&, j%, k%, zf$, d, d2, d3
   
4. Set wd = CreateObject("Word.Application")
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. Set d3 = CreateObject("scripting.dictionary")
   
8. With wd.Documents.Open(ThisWorkbook.Path & "\数据.doc")
   
9.     For k = 1 To .Tables.Count
   
10.         Cells(k + 2, 1) = k
    
11.         For i = 6 To .Tables(k).Rows.Count
    
12.             zf = Application.Clean(.Tables(k).Cell(i, 5).Range)
    
13.             For j = 7 To 11
    
14.                x = Val(Application.Clean(.Tables(k).Cell(i, j).Range))
    
15.                If zf = "E" Then d(x) = ""
    
16.                If zf = "Seq" Then d2(x) = ""
    
17.                If zf = "H" Then d3(x) = ""
    
18.             Next
    
19.         Next
    
20.         Cells(k + 2, 2) = Application.Max(d.keys)
    
21.         Cells(k + 2, 3) = Application.Min(d.keys)
    
22.         Cells(k + 2, 4) = Application.Max(d2.keys)
    
23.         Cells(k + 2, 5) = Application.Min(d2.keys)
    
24.         Cells(k + 2, 6) = Application.Max(d3.keys)
    
25.         Cells(k + 2, 7) = Application.Min(d3.keys)
    
26.         d.RemoveAll: d2.RemoveAll: d3.RemoveAll
    
27.     Next
    
28.     .Close False
    
29. End With
    
30. wd.Quit
    
31. End Sub

复制代码

跳转到最佳答案楼层

一村之长

函数表示给跪了，坐等VBA高手施法

dsmch

把word文件压缩上传，方便问题解决

lyjlyg06

word格式要转换成excel才能正常操作，跨界的难度大！

上清宫主

没那么牛吧？
一来可以整到E中很简单的就做了
二来可以就在W中用VBA读取判断一下就了事

1261181315a

问题：有的表格只含有因素E 、Seq ,有的含有因素E 、Seq  、H 现在想得到每个表格里各因素的最大值与最小值并写入新的文件（txt/excel）。

1261181315a

求指导呀

1261181315a

上清宫主 发表于 2015-5-20 10:22
没那么牛吧？
一来可以整到E中很简单的就做了
二来可以就在W中用VBA读取判断一下就了事

大神，还请写个代码。数据附件已上传，也让大家都能学习。

上清宫主

没搞明白具体需求，以下代码在word运行，是将所有表的同一个项目的第一个测量的最大值找出来。
Sub test()
Dim d
Set d = CreateObject("Scripting.Dictionary")
For Each t In ThisDocument.Tables
    r = t.Rows.Count
    For i = 6 To r
        s = t.Cell(i, 5).Range.Text
        s = Left(s, Len(s) - 2)
        n = Val(t.Cell(i, 7).Range.Text)
        If d(s) < n Then d(s) = n
    Next
Next
s = ""
For Each t In d.Keys
    s = s & t & "  " & d(t) & Chr(13)
Next
MsgBox s
End Sub
按你的意图自己改去吧，反正又不是好恼火

329577245

好东东可真多呀，借鉴了！