如何通过VB合并Excel单元格以及设置Excel行高?VB创建Excel表格,合并单元格,生成图形等操作

如何通过VB合并Excel单元格以及设置Excel行高?

例如:我想把第一列的第4,5,6,7行合并。。。我在怎样让合并单元格里的字居中,怎样改变字体。 请不吝赐教。。。
==========================================================
首先在VB中引用microsoft excel object library

假设c盘根目录下有个1.xls的文件
…………



问题补充:

你的要求很简单,

一行指令恐怕不行,

最少要三行

代码如下:

Private Sub Form_Load()

Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim i As Integer

Set xlApp = CreateObject("Excel.Application")

Set xlBook = xlApp.Workbooks.Open("C:\1.xls")

Set xlSheet = xlBook.Worksheets(1) '引用第1张工作表

For i = 3 To 100 Step 3 '想到哪行就把100改成几

xlSheet.Range(Cells(i, 1), Cells(i, 2)).Merge '合并a1:b2单元格

Next

xlSheet.Rows(10).RowHeight = 100 '把第10行高度设为100

xlBook.Save

xlApp.Application.Quit

Set xlApp = Nothing '表忘释放引用

End Sub

运行一下,看看满足要求否。
===========================================================================================
Sub Macro1()

Range("A4:A7").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection.Font
.Name = "隶书"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End Sub

=========================================================================================

VB创建Excel表格,合并单元格,生成图形等操作 

Private Sub Command4_Click()
    On Error Resume Next
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''Create Excel Table''''''''''''''''''''''''''''''''''''''''''
       Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim xlSheet1 As Excel.Worksheet
        Dim i As Integer, tmHour As String
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        On Error Resume Next
              
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
       Set xlApp = Excel.Application
       Set xlBook = xlApp.Workbooks.Add
        'xlBook.Activate
       Set xlSheet = xlBook.Worksheets(1) '''''''''''''''''''''''''''''''''引用第1张工作表
            xlApp.ActiveSheet.Rows.VerticalAlignment = xlVAlignCenter '''''垂直方向居中
            xlApp.ActiveSheet.Rows.HorizontalAlignment = xlVAlignCenter '''水平方向居中
            xlSheet.Name = "实测值"
         Set xlSheet1 = xlBook.Worksheets(2)
         xlSheet1.Name = "Chart"
       With xlSheet
             For i = 2 To 11
                .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
             
             ''''''''''''''''''''''''''设置行高'设置列宽
             For i = 1 To 22
                .Rows(i).RowHeight = 25
             Next
             For i = 1 To 11
              .Columns(i).ColumnWidth = 15
             Next
             '''''''''''''''''''''''''''合并单元格
             For i = 3 To 22
                 
                   If i < 8 Then
                        .Range(Cells(3, 1), Cells(i, 1)).Merge '''''''''''合并A3-A7单元格
                        .Range(Cells(3, 8), Cells(i, 8)).Merge '''''''''''合并H3-H7单元格
                   ElseIf i < 13 Then
                        .Range(Cells(8, 1), Cells(i, 1)).Merge
                        .Range(Cells(8, 8), Cells(i, 8)).Merge
                   ElseIf i < 18 Then
                        .Range(Cells(13, 1), Cells(i, 1)).Merge
                        .Range(Cells(13, 8), Cells(i, 8)).Merge
                   ElseIf i < 23 Then
                        .Range(Cells(18, 1), Cells(i, 1)).Merge
                        .Range(Cells(18, 8), Cells(i, 8)).Merge
                   End If
             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/4 Load"
            .Range("D5").Value = "2/4 Load"
            .Range("D6").Value = "3/4 Load"
            .Range("D7").Value = "Full Load"
            .Range("D8").Value = "0"
            .Range("D9").Value = "1/4 Load"
            .Range("D10").Value = "2/4 Load"
            .Range("D11").Value = "3/4 Load"
            .Range("D12").Value = "Full Load"
            .Range("D13").Value = "0"
            .Range("D14").Value = "1/4 Load"
            .Range("D15").Value = "2/4 Load"
            .Range("D16").Value = "3/4 Load"
            .Range("D17").Value = "Full Load"
            .Range("D18").Value = "0"
            .Range("D19").Value = "1/4 Load"
            .Range("D20").Value = "2/4 Load"
            .Range("D21").Value = "3/4 Load"
            .Range("D22").Value = "Full Load"
     End With
        tmHour = "-" & Hour(Time)
        tmHour = tmHour & "-" & Minute(Time)
        tmHour = tmHour & "-" & Second(Time)
        xlApp.ActiveWorkbook.SaveAs App.Path & "\" & Format(Date, dddd, mmmm, yyyy) & tmHour + ".xls"
        xlApp.Workbooks.Close
        xlApp.Quit
        Set xlApp = Nothing '释放引用
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''写入数据'''''''''''''''''''''''''''''''''''''''''''''
Dim j, LengthTXT, k, Num, NEXCEL As Integer
Dim StrTxt As String
On Error Resume Next
'''''''''''''''''''''''''''计算数组的围数 NUM
    LengthTXT = Len(Text1.Text)
    StrTxt = Text1.Text
    Num = 1
    For i = 1 To LengthTXT
       If Mid(Text1.Text, i, 1) = "," Then
          Num = Num + 1
       End If
    Next
     ReDim StrDataArray(Num)  '重定义围数
'''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''赋值给数组 StrDataArray
    If Num = 1 Then
        StrDataArray(Num) = StrTxt
    Else
        For i = 1 To LengthTXT
            StrData = StrData & Mid(StrTxt, i, 1)
            k = k + 1
            If Mid(StrTxt, i, 1) = "," Then
                j = j + 1
                StrDataArray(j) = Left(StrData, k - 1)
                StrData = ""
                k = 0
            End If
              StrDataArray(Num) = StrData
        Next
    End If
'    '''''''''''''''''''''''''''''check StrDataArray(i)
'    For i = 1 To Num
'    MsgBox StrDataArray(i) & "  " & i
'    Next
    '''''''''''''''''''''''''''''''''''数值分段存储到数组,每组为一个实测值
    Dim TowArray() As String
    Dim WS, N As Integer
    WS = Num \ 4 '''''''''''''''''围数
    ReDim TowArray(WS, 4)
     For i = 1 To Num - 2
        N = i \ 4
        For j = 1 To 4
          'If i \ 4 = 0 Then
            TowArray(N + 1, j) = StrDataArray(j + 4 * N)
         ' End If
        Next
     Next
    
'    ''''''''''''''''''''''''''''''''check  TowArray(N + 1, j)
'    For i = 1 To WS
'      MsgBox TowArray(i, 1) & TowArray(i, 2) & TowArray(i, 3) & TowArray(i, 4)
'    Next
'    ''''''''''''''''''''''''''''''''''数值转换
    ''''第4个字节转换为2进制


ReDim ByteDataString(WS)
    For i = 1 To Num \ 4
       'MsgBox TowArray(i, 4) MsgBox CStr(TowArray(i, 4))
       ByteDataString(i) = HexToByte(CStr(TowArray(i, 4))) '''''转换为2进制,8位
       'MsgBox ByteDataString(i) & " " & i
Next
    '''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''''''''打开Excel 文件!
    Dim filename As String
    With CommonDialog1
        .DialogTitle = "打开Excel文件"

        .Filter = "(Excel)*.xls| *.xls"
        .ShowOpen
        filename = .filename
       ' MsgBox filename
    End With
    '''''''''''''''''''''''''
    Dim xllApp As Excel.Application
    Dim xllBook As Excel.Workbook
    Dim xllSheet As Excel.Worksheet
    Dim xllSheet1 As Excel.Worksheet
    Dim StrRow As String
'Dim i As Integer
    Set xllApp = CreateObject("Excel.Application")
    Set xllBook = xllApp.Workbooks.Open(filename)
    Set xllSheet = xllBook.Worksheets(1) '引用第1张工作表
    Set xllSheet1 = xllBook.Worksheets(2)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''将数据写入到Excel单元格中

    With xllSheet
        For i = 1 To WS
             NEXCEL = i
             StrRow = "B" & CStr(i + 2)
            ' MsgBox ByteDataString(i) '& StrRow
            .Range(StrRow).Value = ValueOfData(ByteDataString(i), NEXCEL) '''''设置一个返回函数
        Next
    End With
    Set ct = xllApp.Worksheets("Chart").ChartObjects.Add(100, 40, 300, 350) '插入图形''位置(10,40)为图形位置,(220,120)为图形的大小
    ct.Chart.ChartType = xlLineStacked 'xlColumnClustered '块状图 'xl3DColumnStacked '立體直條圖'xl3DPie '图形类型为饼图
    ct.Chart.SetSourceData Source:=Sheets("实测值").Range("B3:B6"), PlotBy:=xlColumns
    With ct.Chart
         .HasTitle = True
         .ChartTitle.Characters.Font.Size = 20
         .ChartTitle.Characters.Text = "折线图" '图表标题为饼图
         .ChartTitle.Shadow = True ''''''标题添加边框
    End With
     ct.Chart.ApplyDataLabels 2, True '标志旁附图例项标志***  标志数值
        xllBook.Save
        xllApp.ActiveWorkbook.Save
        xllApp.Application.Quit
    Set xllApp = Nothing '表忘释放引用
End Sub

参与评论 您还未登录,请先 登录 后发表或查看评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页

打赏作者

hljqfl

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值