[第6期] WORD表格空行删除和零值填充[已完成]

qee用

Option Explicit

Sub 方法1_49秒()
Dim i%, j%, ln%, clm%
Dim t
t = Timer
Application.ScreenUpdating = False
With ThisDocument.Tables(1)
ln = .Rows.Count
clm = .Columns.Count
For i = ln To 2 Step -1
If Len(.Rows(i).Range.Text) = 2 * (clm + 1) Then
.Rows(i).Delete
Else
For j = 1 To clm
If Len(.Cell(i, j).Range.Text) = 2 Then .Cell(i, j).Range.Text = 0
Next j
End If
Next i
ln = .Rows.Count
For i = 4 To ln Step 4
.Rows(i).Range.Bold = True
Next i
End With
Application.ScreenUpdating = True
MsgBox Timer - t '用时49秒 in AMD 毒龙700/128M
End Sub
Sub 方法2_25秒()
Dim i%, rw As Row, rg As Cell
Dim t
t = Timer
Application.ScreenUpdating = False
With ThisDocument.Tables(1)
For Each rw In .Rows
If Len(rw.Range.Text) = 22 Then
rw.Delete
Else
For Each rg In rw.Cells
If Len(rg.Range.Text) = 2 Then rg.Range.Text = 0
Next rg
End If
Next rw
For i = 4 To .Rows.Count Step 4
.Rows(i).Range.Bold = True
Next i
End With
Application.ScreenUpdating = True
MsgBox Timer - t '用时25秒 in AMD 毒龙700/128M
End Sub
Sub 方法3_16秒()
Dim i%, rw As Row, rg As Cell
Dim t
t = Timer
Application.ScreenUpdating = False
With ThisDocument.Tables(1)
For Each rw In .Rows
If Len(rw.Range.Text) = 22 Then rw.Delete
Next rw
For i = 4 To .Rows.Count Step 4
.Rows(i).Range.Bold = True
Next i
End With
ThisDocument.Tables(1).Select
For Each rg In Selection.Cells
If Len(rg.Range.Text) = 2 Then rg.Range.Text = 0
Next rg
Application.ScreenUpdating = True
MsgBox Timer - t '用时16秒 in AMD 毒龙700/128M
End Sub

[此贴子已经被守柔于2005-12-23 6:09:57编辑过]

shuyee

以下是用操作实现目标:
1.选中表格,把表格转换成文本,分隔符号选制表符,再把制表符(^t)替换成","(把表格直接转成逗号时,逗号前会有多余字符)
2.再把",,,,,,,,,^p"(9个逗号加段落标志)替换掉--这是在删空行
3.再把",,"替换成",0,",这个要重复一次,然后再把",^p"换成",0^p",防止最后一列为空,最后再把"^p,"换成"^p0,"防止首列为空
4.再在"表格"菜单中选中文字转换成表格,分隔符选逗号
5.选中第一列,右击鼠标,选插入一列.在第一个单元格输入";",然后选中第一列的前4个单元格,并复制,再选中第一列,并粘贴,再复制(第一列),把输入焦点移到表格外第一行的段落标志前,粘贴.
6.再选中表格,把表格转换成文本,用查找,把"突出显示..."方框打上勾,使用通配符,查找字符串":*:",点查找全部,关掉查找对话框,选粗体字(Ctrl+b).,按Ctrl+End到达文件末尾,按delete,删掉多余的一行(这是表格造成的,也可能不删,).按Ctrl+a,选中全部文本(如果不删那一个空段落标志,就用Shift+Ctrl+Home选中文本).
7.再把文本转换成表格,用默认设置就行.然后把第一列和最后一列删除.选中表格第一行按Ctrl+b(为的是标题行加粗,由于原文档有加粗,这样在上次加粗时它失效了,因此要再加粗),再点"表格"菜单中的"表格属性",在"行"标签里,勾中"在各页顶端以标题行...",再到"列"标签中去,点"后一列",设置各列列宽2,1.5,2.5,2.5,1.5,1,1.5,2, 1.5,4).注意,如果不点"后一列"按钮时,设置的是所有列的列宽,对话框中有显示.最后确认,完工.

Sub SixthMacro()
Dim ColsW As Variant, myTable As Table, i%, tmpCell As Cell, pP$
ColsW = Array(2, 1.5, 2.5, 2.5, 1.5, 1, 1.5, 2, 1.5, 4) '表格列宽
Set myTable = ThisDocument.Tables(1) '把表赋给变量
Debug.Print Now()
With myTable
.Rows(1).HeadingFormat = False '取消标题行
.Range.Font.Bold = False '取消粗体字
Do
i = i + 1 '首行行号是1,故i要+1
Application.StatusBar = "正在处理: 空行..." & i
If Len(.Rows(i).Range.Text) = 22 Then '空单元格仍包括2个字符chr(13)和chr(7),如果能用字符表达出来,程序可以更快
.Rows(i).Delete '删空行
i = i - 1 '回到前一行,重新开始
End If
Loop Until i >= .Rows.Count '对每一行进行处理
For i = 1 To .Rows.Count Step 4 '每4行,所以step为4
.Rows(i).Range.Font.Bold = True '设置为粗体
Application.StatusBar = "正在处理: 第4行们..." & i
Next
Application.StatusBar = "正在处理: 空值..."
For Each tmpCell In .Range.Cells '在各单元格间循环
If Len(tmpCell.Range.Text) = 2 Then tmpCell.Range.Text = 0 '空的置0
Next
' Replace .Range.Text, "Zero", 0
.Rows(1).HeadingFormat = True '设置标题行
Application.StatusBar = "正在处理: 表格列宽..."
For i = 1 To .Columns.Count
.Columns(i).Width = CentimetersToPoints(ColsW(i - 1)) '设置表格列宽
Next
Application.StatusBar = False
.Cell(1, 1).Select
End With
Set myTable = Nothing
Debug.Print Now()
End Sub

[此贴子已经被守柔于2005-12-23 6:11:23编辑过]

qee用

操作步骤：
1 光标移至表的（1，1）单元格。（i，j）表示第i行，j列。
2 表格-转换-表格转换成文字-文字分隔符：制表符-确定。
3 任选一空白行（比如第7行），选定，Ctrl+C复制。
4 光标移到文件头-编辑-替换-查找内容：Ctrl+V粘贴，替换为：空-全部替换（询问时回答是，保证替换无遗漏）
5 编辑-替换-查找内容：^p^p，替换为：^p-多次点击全部替换（询问时反复回答是，直至保证替换无遗漏-系统提示“只有1行被替换”，即删除所有空行）
6 光标移到文件头-编辑-替换-查找内容：^p^t，替换为：^p0^t-全部替换
7 光标移到文件头-编辑-替换-查找内容：^t^t，替换为：^t0^t-全部替换
8 选定除最后一行（空行）以外的所有内容
9 表格-转换-文字转换为表格-使用默认的设置即可设置为10列且列宽与原表一致（不需另行调整）
10 光标移入首行任一单元格-表格-标题行重复
11 选定第4行-字体加粗（即点击工具栏的按钮B）
12 编辑-定位-定位目标：行，行号：+4
13 点击“定位”按扭
14 选定被定位的行-字体加粗（即点击工具栏的按钮B）
15 重复13，14直至结束。

VBA代码：
Sub 方法()
Dim i%, rw As Row, rg As Cell
Application.ScreenUpdating = False
With ThisDocument.Tables(1)
For Each rw In .Rows
If Len(rw.Range.Text) = 22 Then rw.Delete
Next rw
For i = 4 To .Rows.Count Step 4
.Rows(i).Range.Bold = True
Next i
End With
ThisDocument.Tables(1).Select
For Each rg In Selection.Cells
If Len(rg.Range.Text) = 2 Then rg.Range.Text = 0
Next rg
'偶然发现题目要求有这样一段，故补充以下代码：
'表格的列宽分别为2,1.5,2.5,2.5,1.5,1,1.5,2,1.5,4厘米，首行重复标题行。
ActiveDocument.Tables(1).Rows(1).HeadingFormat = True
With ThisDocument.Tables(1)
.Columns(1).Width = Application.CentimetersToPoints(2)
.Columns(2).Width = Application.CentimetersToPoints(1.5)
.Columns(3).Width = Application.CentimetersToPoints(2.5)
.Columns(4).Width = Application.CentimetersToPoints(2.5)
.Columns(5).Width = Application.CentimetersToPoints(1.5)
.Columns(6).Width = Application.CentimetersToPoints(1)
.Columns(7).Width = Application.CentimetersToPoints(1.5)
.Columns(8).Width = Application.CentimetersToPoints(2)
.Columns(9).Width = Application.CentimetersToPoints(1.5)
.Columns(10).Width = Application.CentimetersToPoints(4)
End With
Application.ScreenUpdating = True
End Sub

[此贴子已经被守柔于2005-12-23 6:04:56编辑过]

prince

前面发了个VBA解法,这里再给个手动解法.

第一步:选中该表格,单击菜单:表格>转换>表格转换为文字>文字分隔符为制表符.
第二步:以"^t^t^t^t^t^t^t^t^t^p"为查找内容,替换成无.(共替换40个)
第三步:以"^t^t"为查找内容,替换成"^t0^t",重复执行这一步,直到提示共替换0处.
这一步共替换417+179处.
第四步:以"^t^p"为查找内容,替换成"^t0^p",共替换79处.
第五步:以"^p^t"为查找内容,替换成"^p0^t",共替换71处.
第六步:查找结束,重新转换为表格.
第七步:选中标题行,单击表格>表格属性>行>在各页顶端以标题行形式重复出现.
第八步:单击表格>表格属性>列,设置各列宽度.
经过以上几步,基本完成了任务.至于4的倍数行为粗体我不会了.
查看一下:共746个0,每列依次为71,72,71,76,67,76,76,80,78,79

Sub Prince()
Dim mCW '列宽数组
Dim mRows As Rows '行集合变量
Dim mRow As Row '行变量
Dim mCell As Cell '单元格变量
Dim x As Integer '行数计数标志
Dim mSU As Boolean, mAS As Boolean '环境变量
Dim mTime
mTime = Timer
mSU = Application.ScreenUpdating
mAS = Application.DisplayStatusBar
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.StatusBar = "正在处理..."
'表格的列宽分别为2,1.5,2.5,2.5,1.5,1,1.5,2,1.5,4厘米，首行重复标题行。
mCW = Array(2, 1.5, 2.5, 2.5, 1.5, 1, 1.5, 2, 1.5, 4)
With ThisDocument.Tables(1).Columns
For x = 0 To 9
.Item(x + 1).Width = CentimetersToPoints(mCW(x))
Next
End With
Set mRows = ThisDocument.Tables(1).Rows
mRows(1).HeadingFormat = True
x = 0
For Each mRow In mRows
With mRow
x = x + 1
If x Mod 4 = 1 Then .Range.Font.Bold = True
DoEvents
If Len(.Range.Text) = 22 Then
.Delete
x = x - 1
Else
For Each mCell In .Cells
With mCell.Range
If Len(.Text) = 2 Then
.Text = "0"
End If
End With
Next
End If
End With
Next
MsgBox "本次程序执行共耗时" & Timer - mTime & "秒!"
Application.ScreenUpdating = mSU
Application.DisplayStatusBar = mAS
End Sub

rongjun

常规解法：

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ActiveDocument.Tables(1).Select
Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _
NestedTables:=True
Selection.Find.ClearFormatting
With Selection.Find
.Text = "---------^p"
.Replacement.Text = ""
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "^p"
.Replacement.Text = "-"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "--"
.Replacement.Text = "-0-"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Selection.ConvertToTable Separator:=wdSeparateByDefaultListSeparator, _
NumColumns:=40, AutoFitBehavior:=wdAutoFitContent
Selection.Tables(1).Columns(40).Select
Selection.MoveLeft Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Selection.Font.Bold = True
Selection.Tables(1).Select
Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _
NestedTables:=True
Selection.ConvertToTable Separator:=wdSeparateByDefaultListSeparator, _
NumColumns:=10, AutoFitBehavior:=wdAutoFitContent
Selection.Tables(1).Style = "典雅型"
Selection.Tables(1).AllowAutoFit = True
Selection.Columns(1).PreferredWidth = CentimetersToPoints(2)
Selection.Columns(2).PreferredWidth = CentimetersToPoints(1.5)
Selection.Columns(3).PreferredWidth = CentimetersToPoints(2.5)
Selection.Columns(4).PreferredWidth = CentimetersToPoints(2.5)
Selection.Columns(5).PreferredWidth = CentimetersToPoints(1.5)
Selection.Columns(6).PreferredWidth = CentimetersToPoints(1)
Selection.Columns(7).PreferredWidth = CentimetersToPoints(1.5)
Selection.Columns(8).PreferredWidth = CentimetersToPoints(2)
Selection.Columns(9).PreferredWidth = CentimetersToPoints(1.5)
Selection.Columns(10).PreferredWidth = CentimetersToPoints(4)
Selection.Rows(1).Select
Selection.Rows.HeadingFormat = True
Selection.Tables(1).Select
Selection.Rows.Alignment = wdAlignParagraphCenter
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim r As Row, x As Integer, t As Integer, i As Integer
Application.ScreenUpdating = False
For Each r In ActiveDocument.Tables(1).rows
t = 0
i = i + 1
For x = 1 To 10
If ActiveDocument.Tables(1).Cell(i, x).Range.Characters.Count = 1 Then
ActiveDocument.Tables(1).Cell(i, x).Range.InsertAfter "0"
t = t + 1
End If
Next
If t = 10 Then
ActiveDocument.Tables(1).rows(i).Delete
i = i - 1
ElseIf i Mod 4 = 0 Then ActiveDocument.Tables(1).rows(i).Range.Font.Bold = True
End If
Next
With ActiveDocument.Tables(1)
.Columns(1).PreferredWidth = CentimetersToPoints(2)
.Columns(2).PreferredWidth = CentimetersToPoints(1.5)
.Columns(3).PreferredWidth = CentimetersToPoints(2.5)
.Columns(4).PreferredWidth = CentimetersToPoints(2.5)
.Columns(5).PreferredWidth = CentimetersToPoints(1.5)
.Columns(6).PreferredWidth = CentimetersToPoints(1)
.Columns(7).PreferredWidth = CentimetersToPoints(1.5)
.Columns(8).PreferredWidth = CentimetersToPoints(2)
.Columns(9).PreferredWidth = CentimetersToPoints(1.5)
.Columns(10).PreferredWidth = CentimetersToPoints(4)
.rows(1).Select
Selection.rows.HeadingFormat = True
End With
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim i As Integer, x As Integer, t As Integer
Application.ScreenUpdating = False
For i = ActiveDocument.Tables(1).rows.Count To 1 Step -1
t = 0
For x = 1 To 10
If ActiveDocument.Tables(1).Cell(i, x).Range.Characters.Count = 1 Then
ActiveDocument.Tables(1).Cell(i, x).Range.InsertAfter "0"
t = t + 1
End If
Next
If t = ActiveDocument.Tables(1).Columns.Count Then ActiveDocument.Tables(1).rows(i).Delete
Next
For i = 1 To ActiveDocument.Tables(1).rows.Count
If i Mod 4 = 0 Then ActiveDocument.Tables(1).rows(i).Range.Font.Bold = True
Next
With ActiveDocument.Tables(1)
.Columns(1).PreferredWidth = CentimetersToPoints(2)
.Columns(2).PreferredWidth = CentimetersToPoints(1.5)
.Columns(3).PreferredWidth = CentimetersToPoints(2.5)
.Columns(4).PreferredWidth = CentimetersToPoints(2.5)
.Columns(5).PreferredWidth = CentimetersToPoints(1.5)
.Columns(6).PreferredWidth = CentimetersToPoints(1)
.Columns(7).PreferredWidth = CentimetersToPoints(1.5)
.Columns(8).PreferredWidth = CentimetersToPoints(2)
.Columns(9).PreferredWidth = CentimetersToPoints(1.5)
.Columns(10).PreferredWidth = CentimetersToPoints(4)
.rows(1).Select
Selection.rows.HeadingFormat = True
End With
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
End Sub

[此贴子已经被守柔于2005-12-23 6:15:45编辑过]

qee用

3秒多一点的代码。

Option Explicit

Sub 只需3秒多的方法()
Dim i%, pr As Paragraph
Dim t1
t1 = Timer
Application.ScreenUpdating = False
Selection.Tables(1).Select
Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:=True
For Each pr In Selection.Paragraphs
If Len(pr.Range.Text) = 10 Then pr.Range.Delete
Next pr
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^t^t"
.Replacement.Text = "^t0^t"
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find '执行两次，使连续的空得到替换为0。
.Text = "^t^t"
.Replacement.Text = "^t0^t"
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^t"
.Replacement.Text = "^p0^t"
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^t^p"
.Replacement.Text = "^t0^p"
End With
Selection.Find.Execute Replace:=wdReplaceAll
For i = 4 To Selection.Paragraphs.Count Step 4
Selection.Paragraphs(i).Range.Bold = True
Next i
Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=10, _
Format:=wdTableFormatNone, ApplyBorders:=True, ApplyShading _
:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:=True, _
ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False, _
AutoFit:=True, AutoFitBehavior:=wdAutoFitFixed
ActiveDocument.Tables(1).Rows(1).HeadingFormat = True
ActiveWindow.ActivePane.VerticalPercentScrolled = 0
Selection.MoveUp Unit:=wdLine, Count:=1
Application.ScreenUpdating = True
MsgBox Timer - t1
End Sub

这个方法很快.一并上述VBA评分了.(这次VBA不是重点,见谅哟)

[此贴子已经被守柔于2005-12-23 6:08:22编辑过]

hy8888

比较仓促,代码比较慢,搭个末班车

首先,表格转文本,用制表符隔开,

在替换时,不使用通配符选项,将 ^t^t^t^t^t^t^t^t^t^p 替换掉(即删除空行,多替换几次),

再将^t^t替换成^t0^t,将^t^p替换成^t0^p,将^p^t替换成^p0^t(即将空白用0代替,每次替换至没有可替换的为止),

再使用通配符将^13[^t,0-z]@^13[^t,0-z]@^13[^t,0-z]@^13 替换成 ^&^p,再将^13[^t,0-z]@^13^13 替换成加粗格式的 ^& (隔三行加粗),

最后将所有文本转换为表格,分为10列,以制表符做分隔符,
表格首行标题行重复,调整10列的列宽为2,1.5,2.5,2.5,1.5,1,1.5,2,1.5,4,单位为cm.

shuyee

虽说最终完成了,但对word的查找替换用的却是最基本的方法,看楼上这个方法^13[^t,0-z]@^13[^t,0-z]@^13[^t,0-z]@^13,才是常用word的.佩服.

不过这两步可以改一下,一是全篇加粗,再把^13[^t,0-z]@^13[^t,0-z]@^13[^t,0-z]@^13替换成^&常规就行了.楼上是在第(1,5,..)后加换行,再根据换行找到第(1,5,..)考虑^13[^t,0-z]@^13[^t,0-z]@^13[^t,0-z]@^13是选中后三行,所以直接改不加粗就可以了.

还有不少朋友在VBA代码中加入了替换,当然可以,但如果把表格转成文本,会丢失表格的一些设置.

shuyee

今天早上重试了一下,查找每4行的后3行时,可以用^13*^13*^13*^13,替换内容仍是^&常规,要把通配符打开,其实开始注想到类似的方法,但因使用通配符时不允许使用^p,只好改用前后各增加一列的方法.原来可以这样输入^13.

hy8888

18楼的过奖了,[em04] 这个方法还是在看了不少帖之后,再看帮助才得到的。应该说是论坛里好帖太多了[em08]