|
这个东东太繁了，今天整整花了我三个小时，基本搞定，估计还会有不少问题，可楼主却潇洒去也。代码在附件中，此附件已经程序处理。
衷心希望我们的网友的WORD水平越来越好，这样的东东，再也不要出现了，几乎都找不能规律，靠错误处理来判断，滋味很不好受！
以下代码供参考：
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-3-5 15:01:09
'仅测试于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, CCount As Byte, Temp As Range
Application.ScreenUpdating = False '关闭屏幕更新
On Error Resume Next '忽略错误
For Each aTab In ActiveDocument.Tables '在活动文档的表格中循环
With aTab '对每个aTab表格对象
With .Range
.Font.Name = "宋体" '字体设置
.Font.Size = 10 '字号设置
'最小行距
.Paragraphs.LineSpacingRule = wdLineSpaceAtLeast
.Paragraphs.LineSpacing = 20 '20磅
.Font.NameAscii = "Arial" '西文字体为"Arial"
End With
.AutoFitBehavior wdAutoFitWindow '根据窗口大小自动调整
CCount = .Columns.Count '取得表格列数
RCount = .Rows.Count '取得表格行数
'判断最后第二行是否包含system字符
If InStr(.Cell(RCount - 1, 2).Range.Text, "System") > 0 Then
'设置一个单元格区域
Set Temp = ActiveDocument.Range(.Cell(RCount - 1, 1).Range.Start, .Cell(RCount, CCount - 1).Range.End)
Temp.Select '选中
Selection.Rows.Delete '删除选中行
GoTo Again
'先判断最后一行是否含有Valid N (listwise)字符
ElseIf InStr(.Cell(RCount, 1).Range.Text, "Valid N (listwise)") > 0 Then
.Rows(RCount).Delete
TabString1 = VBA.Replace(.Cell(2, 1).Range.Text, Chr(13), "")
'插入指定字符(已去除段落标记)
ActiveDocument.Range(.Range.Start - 1, .Range.Start - 1).InsertAfter TabString1
'如果有累积百分比字样则
ElseIf .Cell(1, 5).Range.Text Like "累积百分比*" Then
'设置错误陷阱
If Err.Number = 5941 Then Err.Clear: GoTo GoReturn
Again: .Cell(1, 1).Split 1, 2 '分列
For i = 1 To RCount '交叉替换单元格中的内容
.Cell(i, 6).Range.Text = VBA.Replace(.Cell(i, 5).Range.Text, Chr(13), "")
.Cell(i, 5).Range.Text = VBA.Replace(.Cell(i, 3).Range.Text, Chr(13), "")
.Cell(i, 4).Range.Text = VBA.Replace(.Cell(i, 2).Range.Text, Chr(13), "")
Next
'定义一个区域变量
Set Temp = ActiveDocument.Range(.Cell(1, 1).Range.Start, .Cell(RCount, 3).Range.End)
Temp.Select
Selection.Columns.Delete '删除选定列
With .Rows(1).Range.Shading '设置第一行底纹
.Texture = wdTextureNone
.BackgroundPatternColor = wdColorGray15
End With
GoTo SetCell
Else
GoReturn: Select Case CCount
Case 10
'取得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 & ")"
TabString = VBA.Replace(TabString, Chr(13), "")
'在表格之前的位置中插入
ActiveDocument.Range(.Range.Start - 1, .Range.Start - 1).InsertAfter TabString
With .Cell(1, 1) '对1,1单元格
.Split 3, 1 '拆分为3行1列
'该单元格行删除并下方单元格上移
.Range.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
End With
.Cell(2, 8).Range.Text = "频数"
.Cell(2, 9).Range.Text = "百分比"
.Cell(1, 5).Merge merget=.Cell(1, 6)
.Cell(1, 5).Range.Text = "总体"
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属性)
With .Rows(2).Range.Shading
.Texture = wdTextureNone
.BackgroundPatternColor = wdColorGray15
End With
GoTo SetCell
Case 4
TabString1 = ActiveDocument.Range(.Cell(1, 1).Range.Start, .Cell(1, 1).Range.End - 1)
TabString = "附表：" & TabString1
TabString = VBA.Replace(TabString, Chr(13), "")
ActiveDocument.Range(.Range.Start - 1, .Range.Start - 1).InsertAfter TabString
With .Rows(1).Range.Shading
.Texture = wdTextureNone
.BackgroundPatternColor = wdColorGray15
End With
GoTo SetCell
Case 6
TabString1 = ActiveDocument.Range(.Cell(2, 1).Range.Start, .Cell(2, 1).Range.End - 1)
TabString = "附表：" & TabString1
TabString = VBA.Replace(TabString, Chr(13), "")
ActiveDocument.Range(.Range.Start - 1, .Range.Start - 1).InsertAfter TabString
.Rows(3).Delete
End Select
End If
SetCell: .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '段落居中
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '垂直居中
.Borders.InsideLineStyle = wdLineStyleSingle '内部单线
.Borders.InsideLineWidth = wdLineWidth025pt '内部线宽
.Borders.OutsideLineStyle = wdLineStyleSingle '外部单线
.Borders.OutsideLineWidth = wdLineWidth150pt '外部线宽
.Range.Font.Color = wdColorAutomatic '字体
.Rows(1).Range.Font.Bold = True
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
Next aTab
Application.ScreenUpdating = True '恢复屏幕更新
Call SetFormat
End Sub
'----------------------
Sub SetFormat()
Dim i As Paragraph
Application.ScreenUpdating = False '关闭屏幕更新
For Each i In ActiveDocument.Paragraphs '在段落中循环
If InStr(i.Range, "附表") > 0 Then '如果有附表字符
With i.Range
.Font.Name = "宋体" '设置字体格式
.Font.Size = 12 '设置字号
'设置为最小行距
.ParagraphFormat.LineSpacingRule = wdLineSpaceAtLeast
.ParagraphFormat.LineSpacing = 22 '22磅
.ParagraphFormat.SpaceAfter = 12 '段前12磅
End With
End If
Application.ScreenUpdating = True
Next
End Sub
'----------------------
oyHtFCVt.zip
(224.51 KB, 下载次数: 22)
|
楼主: hpw
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-3-1 15:59
楼主
