VB创建Excel表格合并单元格生成图形等操作.docx
《VB创建Excel表格合并单元格生成图形等操作.docx》由会员分享，可在线阅读，更多相关《VB创建Excel表格合并单元格生成图形等操作.docx（8页珍藏版）》请在冰豆网上搜索。
VB创建Excel表格合并单元格生成图形等操作
PrivateSubCommand4_Click（）
OnErrorResumeNext
''''''''''''''''''''''''''''''''''''''''''''''''''''''''CreateExcelTable''''''''''''''''''''''''''''''''''''''''''
DimxlAppAsExcel.Application
DimxlBookAsExcel.Workbook
DimxlSheetAsExcel.Worksheet
DimxlSheet1AsExcel.Worksheet
DimiAsInteger,tmHourAsString
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
OnErrorResumeNext
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
SetxlApp=Excel.Application
SetxlBook=xlApp.Workbooks.Add
'xlBook.Activate
SetxlSheet=xlBook.Worksheets
（1）'''''''''''''''''''''''''''''''''引用第1张工作表xlApp.ActiveSheet.Rows.VerticalAlignment=xlVAlignCenter'''''垂直方向居中
xlApp.ActiveSheet.Rows.HorizontalAlignment=xlVAlignCenter'''水平方向居中
xlSheet.Name="实测值"
SetxlSheet1=xlBook.Worksheets
（2）
xlSheet1.Name="Chart"
WithxlSheet
Fori=2To11
.Range（Cells（1,1）,Cells（1,i））.Merge''''''''''''''''''''合并A-K单元格Next
'.Cells（1,1）.ForeColor=RGB（100,150,255）
.Cells（1,1）.Font.Size=25
''''''''''''''''''''''''''设置行高'设置列宽
Fori=1To22
.Rows（i）.RowHeight=25
Next
Fori=1To11
.Columns（i）.ColumnWidth=15
Next
'''''''''''''''''''''''''''合并单元格
Fori=3To22
Ifi<8Then
单元格
单元格
框
色.Range（Cells（3,1）,Cells（i,1））.Merge'''''''''''合并A3-A7.Range（Cells（3,8）,Cells（i,8））.Merge'''''''''''合并H3-H7ElseIfi<13Then
.Range（Cells（8,1）,Cells（i,1））.Merge
.Range（Cells（8,8）,Cells（i,8））.Merge
ElseIfi<18Then
.Range（Cells（13,1）,Cells（i,1））.Merge
.Range（Cells（13,8）,Cells（i,8））.Merge
ElseIfi<23Then
.Range（Cells（18,1）,Cells（i,1））.Merge
.Range（Cells（18,8）,Cells（i,8））.Merge
EndIf
Next
''''''''''''''''''''''''''''''''''''''''''''
.Range（"A1","K22"）.Borders.LineStyle=xlContinuous'''''''单元格边.Range（"A1","K22"）.Borders.Color=vbBlue'''''''''''''''''边框颜色.Range（"A1","K22"）.Interior.Color=RGB（100,180,0）''''''区域背景''''''''''''''''''''''''''''''
.Range（"A1"）.Value="iWatt项目"
.Range（"A1"）.Font.Color=vbRed''''''''''''''设置字体颜色
.Range（"A1"）.Font.Name="楷书"''''''''''''''设置字体字型
.Range（"A1"）.Font.Size=30''''''''''''''''''设置字体字号
'''''''''''''''''''''''''''''''''''''''
.Range（"A2"）.Value="输入电压（VAC）"
.Range（"B2"）.Value="输入功率（W）"
.Range（"C2"）.Value="输出电压（V）"
.Range（"D2"）.Value="输出电流mA）"
.Range（"E2"）.Value="输出功率（W）"
.Range（"F2"）.Value="纹波电压（A）"
.Range（"G2"）.Value="效率（%）"
.Range（"H2"）.Value="过流点（A）"
.Range（"I2"）.Value="初级到次级功率损耗（W）"
.Range（"J2"）.Value="平均功率%"
.Range（"K2"）.Value="需符合CEC标准"
'''''''''''''''''''''''''''''''''''电压值
.Range（"A3"）.Value="90"
.Range（"A8"）.Value="115"
.Range（"A13"）.Value="230"
.Range（"A18"）.Value="264"
'''''''''''''''''''''''''''''''''''负载值
.Range（"D3"）.Value="0"
.Range（"D4"）.Value="1/4Load"
.Range（"D5"）.Value="2/4Load"
.Range（"D6"）.Value="3/4Load"
.Range（"D7"）.Value="FullLoad"
.Range（"D8"）.Value="0"
.Range（"D9"）.Value="1/4Load"
.Range（"D10"）.Value="2/4Load"
.Range（"D11"）.Value="3/4Load"
.Range（"D12"）.Value="FullLoad"
.Range（"D13"）.Value="0"
.Range（"D14"）.Value="1/4Load"
.Range（"D15"）.Value="2/4Load"
.Range（"D16"）.Value="3/4Load"
.Range（"D17"）.Value="FullLoad"
.Range（"D18"）.Value="0"
.Range（"D19"）.Value="1/4Load"
.Range（"D20"）.Value="2/4Load"
.Range（"D21"）.Value="3/4Load"
.Range（"D22"）.Value="FullLoad"
EndWith
tmHour="-"&Hour（Time）
tmHour=tmHour&"-"&Minute（Time）
tmHour=tmHour&"-"&Second（Time）
xlApp.ActiveWorkbook.SaveAsApp.Path&"\"&Format（Date,dddd,mmmm,yyyy）&tmHour+".xls"
xlApp.Workbooks.Close
xlApp.Quit
SetxlApp=Nothing'释放引用
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''写入数据'''''''''''''''''''''''''''''''''''''''''''''
Dimj,LengthTXT,k,Num,NEXCELAsInteger
DimStrTxtAsString
OnErrorResumeNext
'''''''''''''''''''''''''''计算数组的围数NUM
LengthTXT=Len（Text1.Text）
StrTxt=Text1.Text
Num=1
Fori=1ToLengthTXT
IfMid（Text1.Text,i,1）=","Then
Num=Num+1
EndIf
Next
ReDimStrDataArray（Num）'重定义围数
'''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''赋值给数组StrDataArray
IfNum=1Then
StrDataArray（Num）=StrTxt
Else
Fori=1ToLengthTXT
StrData=StrData&Mid（StrTxt,i,1）
k=k+1
IfMid（StrTxt,i,1）=","Then
j=j+1
StrDataArray（j）=Left（StrData,k-1）
StrData=""
k=0
EndIf
StrDataArray（Num）=StrData
Next
EndIf
''''''''''''''''''''''''''''''checkStrDataArray（i）
'Fori=1ToNum
'MsgBoxStrDataArray（i）&""&i
'Next
'''''''''''''''''''''''''''''''''''数值分段存储到数组,每组为一个实测值
DimTowArray（）AsString
DimWS,NAsInteger
WS=Num\4'''''''''''''''''围数
ReDimTowArray（WS,4）
Fori=1ToNum-2
N=i\4
Forj=1To4
'Ifi\4=0Then
TowArray（N+1,j）=StrDataArray（j+4*N）
'EndIf
Next
Next
'''''''''''''''''''''''''''''''''checkTowArray（N+1,j）
'Fori=1ToWS
'MsgBoxTowArray（i,1）&TowArray（i,2）&TowArray（i,3）&TowArray（i,4）
'Next
'''''''''''''''''''''''''''''''''''数值转换
''''第4个字节转换为2进制
ReDimByteDataString（WS）
Fori=1ToNum\4
'MsgBoxTowArray（i,4）MsgBoxCStr（TowArray（i,4））
ByteDataString（i）=HexToByte（CStr（TowArray（i,4）））'''''转换为2进制,8位'MsgBoxByteDataString（i）&""&i
Next
'''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''打开Excel文件！
DimfilenameAsString
WithCommonDialog1
.DialogTitle="打开Excel文件"
.Filter="（Excel）*.xls|*.xls"
.ShowOpen
filename=.filename
'MsgBoxfilename
EndWith
'''''''''''''''''''''''''
DimxllAppAsExcel.Application
DimxllBookAsExcel.Workbook
DimxllSheetAsExcel.Worksheet
DimxllSheet1AsExcel.Worksheet
DimStrRowAsString
'DimiAsInteger
SetxllApp=CreateObject（"Excel.Application"）
SetxllBook=xllApp.Workbooks.Open（filename）
SetxllSheet=xllBook.Worksheets
（1）'引用第1张工作表
SetxllSheet1=xllBook.Worksheets
（2）
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''将数据写入到Excel单元格中
WithxllSheet
Fori=1ToWS
NEXCEL=i
StrRow="B"&CStr（i+2）
'MsgBoxByteDataString（i）'&StrRow
.Range（StrRow）.Value=ValueOfData（ByteDataString（i）,NEXCEL）'''''设置一个返回函数
Next
EndWith
Setct=xllApp.Worksheets（"Chart"）.ChartObjects.Add（100,40,300,350）'插入图形''位置（10，40）为图形位置，（220，120）为图形的大小
ct.Chart.ChartType=xlLineStacked'xlColumnClustered
测值'块状图'xl3DColumnStacked'立體直條圖'xl3DPie'图形类型为饼图
ct.Chart.SetSourceData
PlotBy:
=xlColumns
Withct.Chart
.HasTitle=True
.ChartTitle.Characters.Font.Size=20
.ChartTitle.Characters.Text="折线图"'图表标题为饼图
.ChartTitle.Shadow=True''''''标题添加边框
EndWith
ct.Chart.ApplyDataLabels2,True'标志旁附图例项标志***标志数值xllBook.Save
xllApp.ActiveWorkbook.Save
xllApp.Application.Quit
SetxllApp=Nothing'表忘释放引用
EndSubSource:
=Sheets（"实"）.Range（"B3:
B6"）,
升级会员 