excelvba编程实例.docx
《excelvba编程实例.docx》由会员分享，可在线阅读，更多相关《excelvba编程实例.docx（28页珍藏版）》请在冰豆网上搜索。
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）.
''''
'选择所有的单元格
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
'
'向表头添加一行
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
EndWith
'往该单元格中写入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
EndWith
（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
EndWith
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="加粗"
.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
EndWith
'加第一二行边框
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=xlAutomatic
EndWith
'合并前两格
'先将其合并
WithSelection
.HorizontalAlignment=xlLeft'靠左对齐
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=False
EndWith
'合并
'对其设定字体风格
With
.Name="Arial"
.FontStyle="加粗倾斜"
.Size=9
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.colorIndex=3
EndWith
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
i=i+1
'加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=True
EndWith
="加粗"
设置第一列结束''''
'''设置第二列'''
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=5
EndWith
WithSelection
.HorizontalAlignment=xlCenter
.VerticalAlignment=xlCenter
.WrapText=True
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=False
EndWith
（xlDiagonalDown）.LineStyle=xlNone
（xlDiagonalUp）.LineStyle=xlNone
With（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
="1"
'将其格式拷贝
'复制格式
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=xlUnderlin
升级会员 