如何一次性"提取表头"和删除"列项"??在线等

hpw

附件中是我的表格, 我是从两千多个表中复制的一个,所有的表格行数和列数是变化的,我想做成的格式如附件中的第二个表所示:

czRUfVpC.rar (4.03 KB, 下载次数: 51)

2005-2-16 13:50 上传

点击文件名下载附件
如何一次性"提取表头"和删除"列项"??在线等

在线等.......[em02][em02][em02][em02]

守柔

虽然不难，但比较繁。希望能见到比较全面的表格（附件中只有一个），我觉得至少有两种方法实现，但均需要编程，需要时间。非在线等而能解决的。

守柔

注意几个问题:

一:由于楼主有大量表格,而本程序代码的运行由于需要多次循环及拆分单元格和设置等,速度有受到影响,需要运行一段时间,其速度受CPU和可用内存影响.

二:第一个表格不是处于文档零位置,也就是文档的第一页的第一个表格上方至少有一行文字;

三:表格之间至少有两个或者两个以上空白段落或者是段落文字.

四:列数问题,从你的一个表格来看,应该影响不大.

五:如有问题,可再交流.

六:请将该代码复制于楼主文档的THISDOCUMENT代码窗口中,使用插入/标准模块也可.

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-2-17 3:23:51 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit '显式变量声明 Sub TabChanges() Dim TabString As String, TabString1 As String, TabString2 As String Dim aTab As Table, i As Integer, RCount As Integer On Error Resume Next '忽略错误 Application.ScreenUpdating = False '关闭屏幕更新 For Each aTab In ActiveDocument.Tables '在活动文档的表格中循环 With aTab '对每个aTab表格对象 '取得1,1单元格中的文本和4,1单元格中的文本 TabString1 = ActiveDocument.Range(.Cell(1, 1).Range.Start, .Cell(1, 1).Range.End - 1) TabString2 = ActiveDocument.Range(.Cell(4, 1).Range.Start, .Cell(4, 1).Range.End - 1) TabString = "附表：" & TabString2 & "(" & TabString1 & ")" '在表格之前的位置中插入 ActiveDocument.Range(.Range.Start - 2, .Range.Start - 1).InsertAfter TabString With .Cell(1, 1) '对1,1单元格 .Split 3, 1 '拆分为3行1列 '该单元格行删除并下方单元格上移 .Range.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow End With RCount = .Rows.Count '定义一个表格总行数 With .Cell(3, 1) '对3,1单元格 '拆分为总行数-最上方2行和最下方一行即得中间部分行数 .Split RCount - 3, 1 .Range.Delete '删除单元格内容 .Select '选定该单元格 End With For i = 3 To RCount - 1 '循环合并指定单元格 .Cell(i, 1).Merge MergeT=.Cell(i, 2) Next Selection.SelectColumn '选定该列(注意表格有行列合并,不能使用ROWS\COLUMNS属性) Selection.Columns.Width = CentimetersToPoints(3) '第一列宽度为3厘米 .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '段落居中 .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '垂直居中 .Borders.InsideLineStyle = wdLineStyleSingle '内部单线 .Borders.InsideLineWidth = wdLineWidth025pt '内部线宽 .Borders.OutsideLineStyle = wdLineStyleSingle '外部单线 .Borders.OutsideLineWidth = wdLineWidth150pt '外部线宽 .Range.Font.Color = wdColorAutomatic '字体 End With Next aTab Application.ScreenUpdating = True '恢复屏幕更新 End Sub '----------------------

hpw

附件是我其中的一个文件,但差不多就都是这样的了.

那个二千页把我们忙得人仰马翻. 到今天看到这个贴子之前我一直没有时间进来,真是感到非常的惭愧呀!让守柔这么费心,而且我早看到,也就不会那么惨了!

不过程序现在运行,还有点问题,请守柔在百忙之中能再帮助解决???!!!![em04][em02]

BplyIWIL.rar (88.42 KB, 下载次数: 23)

2005-2-28 16:12 上传

点击文件名下载附件
如何一次性"提取表头"和删除"列项"??在线等

守柔

请楼主给我一些指示或者批示，实在不行，提示也行，总得说一下，你的要求和问题吧？

hpw

呵呵,[em04]不好意思,我运行你写的程序时,

.Cell(i, 1).Merge MergeT=.Cell(i, 2) 中的MergeT 显示出错

hpw

守柔

应该是 .Cell(i, 1).Merge MergeT=.Cell(i, 2)（原稿是正常的，可是复制后怎么少了啊）

另外，有些表格需要这样做吗？比如挂靠比例分布

均值

频数

标准差

这样的表？

守柔

怪事，你看见了吗？我上面又是复制的，可还是成了：Merge Merget=.

手工打吧！应该是.Cell(i,1).Merge MergeT=.Cell(i,2)

守柔

还是不行，我得找一下总版主，让他看一下，这是原代码，你先用着。

OjsIi0as.txt (2.6 KB, 下载次数: 33)

2005-2-28 17:10 上传

点击文件名下载附件
如何一次性"提取表头"和删除"列项"??在线等