excelvba编程实例.docx
- 文档编号:589008
- 上传时间:2023-04-29
- 格式:DOCX
- 页数:19
- 大小:19.60KB
excelvba编程实例.docx
《excelvba编程实例.docx》由会员分享,可在线阅读,更多相关《excelvba编程实例.docx(19页珍藏版)》请在冰点文库上搜索。
excelvba编程实例
Subdirect_Price()''定义变量
DimcRowsAsInteger'总行数
DimcColumnsAsInteger'总列数
DimHEADERCOLORINDEXAsInteger'表头的背景色
DimcTempAsInteger'临时计数
DimsTempStringAsString'临时字符串变量
DimiAsInteger'临时计数
DimjAsInteger'临时计数
DimrowIndexAsInteger'临时指示处理到哪里
DimcolIndexAsInteger'临时指示处理到哪里
DimtempRndColorAsInteger'临时生成的颜色
DimTABLENAMEAsString'待处理的表名
DimcolorIndexAsString'颜色索引名字
'表头的背景色
HEADERCOLORINDEX=15
colorIndex=36'颜色从33开始是比较浅的颜色
TABLENAME="direct_Price"
'关闭所有弹出的警告消息
=False
'设置需要处理的单元表
Sheets(TABLENAME).Select
'取单元表的总列数与总行数
cRows=Sheets(TABLENAME).=Sheets(TABLENAME).
Illi
选择所有的单元格
Range(Cells(1,1),Cells(cRows,cColumns)).Select
'设置该表中所有单元行高为
设置该表中所有单元行高为
'设置所有的边框
(xlDiagonalDown).LineStyle=xlNone(xlDiagonalUp).LineStyle=xlNone
With(xlEdgeLeft)
.LineStyle=xlContinuous.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeTop)
.LineStyle=xlContinuous.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeBottom)
.LineStyle=xlContinuous.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeRight).LineStyle=xlContinuous.Weight=xlThin.colorIndex=xlAutomatic
EndWith
With(xlInsideVertical).LineStyle=xlContinuous.Weight=xlThin.colorIndex=xlAutomatic
EndWith
'并且拆分所有的单元格
WithSelection.MergeCells=False'拆分单格
EndWith
Columns("C:
C").Select
Shift:
=xlToRight
'删除第一列,注意这里必须先拆分单格,再删除第一列,否则一次就会把合并单元格所在列全部删除
Range(Cells(1,1),Cells(1,1)).Select
I
'向表头添加一行
Rows("1:
1").Select
Columns("A:
A").Select
Columns("B:
B").Select
Columns("C:
C").Select
Columns("D:
D").Select
Columns("E:
E").Select
Columns("F:
F").Select
'''''设定单元格A1:
A2'''合并A1:
A2单元格Range("A1:
A2").Select
'将数据写回
WithSelection
.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.Orientation=0.AddIndent=False.IndentLevel=0.ShrinkToFit=False.ReadingOrder=xlContext.MergeCells=True
往该单元格中写入Usage_Var
="Price"
'设置该单元格字体格式
With(Start:
=1,Length:
=5).Font
.Name="Arial"
.FontStyle=
"加粗倾斜"
.Size=10.Strikethrough=False.Superscript=False
.Subscript=
False
.OutlineFont=False
.Shadow=False
.Underline=
xlUnderlineStyleNone
.colorIndex
=2
EndWith
'单元格设定边框(xlDiagonalDown).LineStyle=xlNone(xlDiagonalUp).LineStyle=xlNone(xlEdgeTop).LineStyle=xlNone
With(xlEdgeBottom)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=56
(xlInsideHorizontal).LineStyle=xlNone
With
.colorIndex=5
.Pattern=xlSolid
.PatternColorIndex=xlAutomatic
EndWith
'设定头两行的内部样式
Range("B1:
B2").Select
Range("C1:
C2").Select
Range("D1:
D2").Select
Range("B1:
D2").Select
设置头两行行高为
With
.Name="Arial"
.FontStyle="加粗"
.Size=8
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.colorIndex=xlAutomatic
EndWith
WithSelection
.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.WrapText=True.Orientation=0.AddIndent=False.IndentLevel=0.ShrinkToFit=False.ReadingOrder=xlContext
EndWith
With
.colorIndex=HEADERCOLORINDEX.Pattern=xlSolid.PatternColorIndex=xlAutomatic
EndWith
Range("B1:
B2").Select
="Type"
With(Start:
=1,Length:
=4).Font.Name="Arial".FontStyle="加粗"
.Size=8
.Strikethrough=False.Superscript=False.Subscript=False.OutlineFont=False.Shadow=False
.Underline=xlUnderlineStyleNone.colorIndex=5
EndWith
Range("E1:
F1").Select
With
.Name="Arial"
.FontStyle="加粗"
.Size=8
.Strikethrough=False.Superscript=False.Subscript=False.OutlineFont=False.Shadow=False
.Underline=xlUnderlineStyleNone.colorIndex=5
WithSelection
.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.WrapText=True
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=True
EndWith
With
.colorIndex=HEADERCOLORINDEX
.Pattern=xlSolid.PatternColorIndex=xlAutomatic
EndWith
="Price"
Range("E2:
F2").Select
设置头两行行高为
With
.Name="Arial
.FontStyle=
II
加粗"
.Size=8
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.colorIndex=xlAutomatic
EndWith
WithSelection
.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.WrapText=True
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=False
EndWith
With
.colorIndex=HEADERCOLORINDEX.Pattern=xlSolid
.PatternColorIndex=xlAutomatic
加第一二行边框
Range("A1:
F2").Select
(xlDiagonalDown).LineStyle=xlNone
(xlDiagonalUp).LineStyle=xlNone
With(xlEdgeLeft)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeTop)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeBottom)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeRight)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlInsideVertical)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlInsideHorizontal)
.LineStyle=xlContinuous.Weight=xlThin.colorIndex=xlAutomatic
EndWith
'去掉第三行的:
号
'sTempString=Right(Cells(3,1),Len(Cells(3,1))-3)
'=sTempString
i=2
j=1
'外层循环判断是否都合并完成,这里插入了一行,加1
Whilei<=cRows
'i=i+1
Range(Cells(i+1,j),Cells(i+1,j)).Select
'去掉分类行中的:
号
If(Len(Cells(i+1,j))>=3)Then
''如果是分格的界限
If(Left(Cells(i+1,j),3)=":
")Then
Range(Cells(i+1,j),Cells(i+1,cColumns)).Select
对第三行进行设定
设置头两行行高为
=18
With
.colorIndex=2
.Pattern=xlSolid
.PatternColorIndex=xlAutomaticEndWith
'合并前两格
'先将其合并
WithSelection
靠左对齐
.HorizontalAlignment=xlLeft'
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False.ReadingOrder=xlContext.MergeCells=FalseEndWith
合并
'对其设定字体风格
With
.Name="Arial"
.FontStyle="加粗倾斜"
.Size=9
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.colorIndex=3EndWith
WithSelection.HorizontalAlignment=xlLeft.VerticalAlignment=xlCenter.WrapText=True
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False.ReadingOrder=xlContext.MergeCells=True
EndWith
sTempString=Right(Cells(i+1,j),Len(Cells(i+1,j))-3)=sTempString
i=i+1
EndIf
EndIf
'加1后判断是否到了表尾,没有继续合并处理
'If(i<=cRows+1)Then
rowIndex=i
'取出Cells(i,j)的内容
sTempString=Cells(i,j)
'循环判断下一个单元格是否和上一个单元格相等,不是则表示到此该合并
WhilesTempString=Cells(i+1,j)Andi<=cRows
i=i+1
Wend
设置第一列''''
'跳出循环表示已经到此该将rowIndex和i行合并
Range(Cells(rowIndex,j),Cells(i,j)).Select
'将原来内容填充进来
=sTempString设合并后的单元格的边框
WithSelection.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.WrapText=True
.Orientation=0
.AddIndent=False.IndentLevel=0
.ShrinkToFit=False.ReadingOrder=xlContext.MergeCells=TrueEndWith="加粗"
设置第一列结束'''''''设置第二列'''Range(Cells(rowIndex,j+1),Cells(i,j+1)).Select
'设置字体
With.Name="Arial".FontStyle="加粗"
.Size=8.Strikethrough=False.Superscript=False.Subscript=False.OutlineFont=False.Shadow=False.Underline=xlUnderlineStyleNone.colorIndex=5EndWith
WithSelection.HorizontalAlignment=xlCenter.VerticalAlignment=xlCenter.WrapText=True
.Orientation=0.AddIndent=False.IndentLevel=0.ShrinkToFit=False.ReadingOrder=xlContext.MergeCells=FalseEndWith
(xlDiagonalDown).LineStyle=xlNone(xlDiagonalUp).LineStyle=xlNoneWith(xlEdgeLeft)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=56
EndWith
With(xlEdgeTop)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=56
EndWith
With(xlEdgeBottom)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=56
EndWith
With(xlEdgeRight)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=56
EndWith
(xlInsideHorizontal).LineStyle=xlNone
设置第二列结束
'修改原来单元格的数据格式''首先向任一无用的单元格写入数据
Range(Cells(cRows+2,cColumns),Cells(cRows+2,cColumns)).Select
将其格式拷贝
'复制格式
Range(Cells(rowIndex,j+4),Cells(i,cColumns)).Select
Paste:
=xlPasteAll,Operation:
=xlMultiply,_
SkipBlanks:
=False,Transpose:
=False
="_*#,##"
'清除原来内容
Range(Cells(cRows+2,cColumns),Cells(cRows+2,cColumns)).Select
设定数据格式完成''''
'''统一设置该区域的颜色''''
'设置内部填充
Range(Cells(rowIndex,j),Cells(i,cColumns)).Select
colorIndex=colorIndex+1
IfcolorIndex>39Then
colorIndex=33
EndIf
With
.colorIndex=colorIndex'颜色
.Pattern=xlSolid
.PatternColorIndex=xlAutomatic
EndWith统一设置该区域的颜色结束''''
设置剩余的列'''
Range(Cells(rowIndex,j+2),Cells(i,cColumns)).Select
'设置字体
With
.Name="Arial"
.FontStyle="常规"
.Size=8
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone.colorIndex=xlAutomatic
EndWith
设置第6列
Range(Cells(rowIndex,j+4),Cells(i,j+5)).Select'设置字体
With
.Name="Arial"
.FontStyle="常规"
.Size=8.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.colorIndex=3
EndWith
'''''设置全部的边框'''
Range(Cells(rowIndex,j),Cells(i,cColumns)).Select'设置边框
(xlDiagonalDown).LineStyle=xlNone
(xlDiagonalUp).LineStyle=xlNone
With(xlEdgeLeft)
.LineStyle=xlContinuous
.Weight=xlThin
.colorIndex=xlAutomatic
EndWith
With(xlEdgeTop)
.LineStyle=xlContinuous.Weight=xlThin.colorIndex=xlAutomatic
EndWith
With(xlEdgeBottom).LineStyle=xlContinuous.Weight=xlThin.colorIndex=xlAutomatic
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- excelvba 编程 实例