ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 守柔

[Word 应用与开发] [第6期] WORD表格空行删除和零值填充[已完成]

[复制链接]

TA的精华主题

TA的得分主题

发表于 2005-12-15 23:38 | 显示全部楼层


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编辑过]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-16 14:23 | 显示全部楼层

答案2种方法

以下是用操作实现目标:
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编辑过]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-16 23:25 | 显示全部楼层


操作步骤:
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编辑过]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-18 10:15 | 显示全部楼层

前面发了个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

TA的精华主题

TA的得分主题

发表于 2005-12-18 14:18 | 显示全部楼层

常规解法:


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编辑过]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-19 19:41 | 显示全部楼层

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编辑过]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-20 10:27 | 显示全部楼层

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

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

在替换时,不使用通配符选项,将 ^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.

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2005-12-21 13:47 | 显示全部楼层

虽说最终完成了,但对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代码中加入了替换,当然可以,但如果把表格转成文本,会丢失表格的一些设置.

TA的精华主题

TA的得分主题

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

TA的精华主题

TA的得分主题

发表于 2005-12-23 11:29 | 显示全部楼层

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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 08:08 , Processed in 0.056230 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表