技巧篇：常用的vba代码汇总

作者介绍

Part.1 生成workbook下的目录

Part.2 移动目录到第一个位置

Sub move_sheet_index()Dim wb As WorkbookDim sht As WorksheetDim dht As WorksheetDim iDim sheet_nameDim indexSet wb = ThisWorkbookSet sht = wb.Sheets("目录")For i = 2 To 38  sheet_name = sht.Cells(i, 2)  index = sht.Cells(i, 7)  wb.Sheets(sheet_name).Move After:=Sheets(i - 1)NextEnd Sub

Sub Update_Content()Application.ScreenUpdating = FalseDim wk As WorkbookDim sht_content As WorksheetSet wk = ThisWorkbookSet sht_content = wk.Sheets("目录")  sht_content.Range("b:c").ClearContents  Call Generate_Content_GeneralApplication.ScreenUpdating = TrueEnd Sub

Part.4 取消隐藏单元格

Sub Cancel_Hidden()Dim sht As WorksheetFor Each sht In Sheetssht.Visible = xlSheetVisibleNextEnd Sub

Part.5 删除workbook下的代码模块

Part.6 vba中用sql模块

Function exe_sql(ds, sql As String)Dim conn As ObjectDim spath$Dim i As Integer, j, k%, t As Integer, Trow%, Tcolumn%Dim columns, dataDim rst As ObjectSet conn = CreateObject("adodb.connection")Set rst = CreateObject("adodb.recordset")conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & dsIf sql = "" Then     MsgBox "请输入SQL语句"     Exit FunctionElse    rst.Open sql, conn, 3    i = rst.Fields.Count       ReDim columns(1 To i)       ' 记录获取的列名    For k = 1 To i        columns(k) = rst.Fields(k - 1).Name    Next       If rst.RecordCount > 0 Then j = rst.RecordCount       ReDim data(1 To j, 1 To i)        t = 1    Do While rst.EOF = False         For k = 1 To i            If Not IsNull(rst.Fields(k - 1)) Then               data(t, k) = rst.Fields(k - 1).Value            End If         Next         rst.movenext         t = t + 1    LoopEnd Ifexe_sql = Array(columns, data)End Function

Part.7 通用的一些function

Function Extract(sql As String, f As String)'#@@ 拽数，并返回数组Dim cnn As Object, rst As ObjectDim r_arr, arrDim i, j'#@@@@# 大前提On Error GoTo Err_HandleIf sql = "" Then Extract = 0: Exit Function'#@@@@# 正常执行    Set cnn = CreateObject("adodb.connection")    Set rst = CreateObject("adodb.recordset")'  cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=YES';data source=" & f    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & f'    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & f'# imex=1 数据导入模式   'rst = cnn.Execute(sql) | rng.copyfromrecordset rst | rst.fields.count | rst.recordcount    rst.Open sql, cnn, 3    i = rst.RecordCount    If i <> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst    If Not IsArray(arr) Then Extract = Array("无记录"): Exit Function    ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1))    i = rst.Fields.Count '#@@@@# 这里属于标题部分    For j = 1 To i        r_arr(0, j - 1) = rst.Fields(j - 1).Name    Next    rst.movefirst    rst.Close:    cnn.Close    Set rst = Nothing:    Set cnn = Nothing '#@@@@# 二维转换    For j = 0 To UBound(arr, 2)            For i = 0 To UBound(arr)                    r_arr(j + 1, i) = arr(i, j)            Next    Next        Extract = r_arr    'Debug.Print "Over"    Exit Function    '#@@@@# 错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0Err_Handle:    Extract = Err.DescriptionEnd FunctionFunction Extract_Origin(sql As String, f As String)' #@@ 拽数，并返回数组Dim cnn As Object, rst As ObjectDim r_arr, arrDim i, j' #@@@@# 大前提On Error GoTo Err_HandleIf sql = "" Then Extract_Origin = 0: Exit Function' #@@@@# 正常执行    Set cnn = CreateObject("adodb.connection")    Set rst = CreateObject("adodb.recordset")' cnn.Open "    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & f' cnn.Open "'# imex=1 数据导入模式'rst = cnn.Execute(sql) | rng.copyfromrecordset rst | rst.fields.count | rst.recordcount    rst.Open sql, cnn, 3    If rst.RecordCount > 0 Then        arr = rst.getrows        ReDim r_arr(UBound(arr, 2), UBound(arr, 1))        For j = 0 To UBound(arr, 2)                For i = 0 To UBound(arr)                        r_arr(j, i) = arr(i, j)                Next        Next    Else        r_arr = 0    End If            Extract_Origin = r_arr        rst.Close    cnn.Close        Set rst = Nothing    Set cnn = Nothing    'Debug.Print "Over"    Exit Function'#@@@@#错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0Err_Handle:    Extract_Origin = Err.DescriptionEnd FunctionFunction CheckWkOpen(ByVal f)Dim tk As WorkbookDim statusstatus = 0For Each tk In Workbooks      If StrComp(f, "book1.xls", 1) = 0 Then            MsgBox f & " is open"            Application.Windows(f).Visible = True            Workbooks(f).Close False            status = 1      End IfNextEnd FunctionFunction CheckFile(spath)Dim fso As ObjectSet fso = CreateObject("scripting.filesystemobject")CheckExists = fso.fileexists(spath)End FunctionFunction CheckTable(wk As Workbook, zstr As String)Dim sht As WorksheetDim statusFor Each sht In wk.Sheets    If sht.Name = zstr Then        status = 1        Exit For    Else        status = 0    End IfNextCheckTable = statusEnd FunctionSub tt()ActiveWorkbook.RemovePersonalInformation = FalseEnd SubFunction 拽数(sql As String, f As String)'@@拽数，并返回数组Dim cnn As Object, rst As ObjectDim r_arr, arrDim i, j    Set cnn = CreateObject("adodb.connection")    Set rst = CreateObject("adodb.recordset")    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source= " & f    On Error GoTo Err_Handle    rst.Open sql, cnn, 3    i = rst.RecordCount    If i <> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst    ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1))    i = rst.Fields.Count    For j = 1 To i        r_arr(0, j - 1) = rst.Fields(j - 1).Name    Next    rst.movefirst    rst.Close    cnn.Close    Set rst = Nothing    Set cnn = Nothing    For j = 0 To UBound(arr, 2)        For i = 0 To UBound(arr)            r_arr(j + 1, i) = arr(i, j)        Next    Next    拽数 = r_arr    Set rst = Nothing    Set cnn = Nothing    Exit FunctionErr_Handle:    Debug.Print Err.DescriptionEnd Function

Part.8 vba自动生成图表

Attribute VB_Name = "Generate_Chart"Option Explicit'=======================================下面为VBA自动生成部分=======================================Sub Chart_Initial(C_row As Integer, C_column As Integer, ChartName As String, C_width As Integer, C_height)'C_row,C_Column 存放行列位置,ChartName 存放表,C_width C_height 存放大小Dim XTitle, YTitleDim Crng As Range, Xrng As Range, rng As RangeDim sht As Worksheet, wb1 As WorkbookDim MyChart As ChartObjectDim R1, C, zstrSet wb1 = ThisWorkbookSet sht = wb1.Sheets("ChartData")R1 = sht.ChartObjects.CountIf R1 > 0 Then        For Each C In sht.ChartObjects            zstr = C.Name            If zstr = ChartName Then C.Delete        NextEnd If'第一部分：创建一个新的图表Object事件Set rng = sht.Cells(C_row, C_column)Set MyChart = sht.ChartObjects.Add(rng.Left, rng.Offset(1, 0).Top, rng.Width * C_width, rng.Height * C_height)With MyChart        .Name = ChartNameEnd With'第二部分：设置图表区格式With MyChart.chart.ChartArea        .Font.Name = "宋体"        .Font.Size = 8        .Font.ColorIndex = xlAutomatic        .Border.LineStyle = 0        .Interior.ColorIndex = xlAutomatic  '图表区填充End With'第三部分：设置绘图区格式With MyChart.chart.PlotArea        .Border.ColorIndex = 15        .Border.Weight = xlThin'        .Border.LineStyle = xlDot        .Border.LineStyle = xlDot        .Interior.ColorIndex = xlNone   '绘图区填充End With'第五部分：设置图表标题MyChart.chart.HasTitle = TrueWith MyChart.chart.ChartTitle        .Text = "<p>string</p>"        .Font.Name = "宋体"        .Font.Bold = True        .Font.Size = 9        .Top = 0End WithEnd SubSub Chart_FillData(MyChart As ChartObject, SerieName As String, Xrng As Range, Yrng As Range)With MyChart.chart        Dim ns        Set ns = .SeriesCollection.NewSeries        ns.Values = Xrng        If Not Yrng Is Nothing Then ns.XValues = Yrng        ns.Name = SerieNameEnd WithEnd SubSub Chart_FinalStyle(MyChart As ChartObject)With MyChart.chart' .ChartTitle.Left = (myChart.Chart.ChartArea.Width / 2) - (myChart.Chart.ChartTitle.Width / 2)End WithEnd SubSub Chart_Axes(MyChart As ChartObject)MyChart.chart.Axes(xlValue).HasMajorGridlines = TrueWith MyChart.chart.Axes(xlValue).MajorGridlines.Border            .ColorIndex = 15            .Weight = xlHairline            .LineStyle = xlDotEnd WithEnd SubSub Chart_SeriesPoint(MyChart As ChartObject, S1)Dim ms As SeriesCollectionMyChart.ActivateActiveChart.SeriesCollection(1).Points(S1).SelectWith Selection.Format.Fill        .Visible = msoTrue        .ForeColor.ObjectThemeColor = msoThemeColorAccent2        .ForeColor.TintAndShade = 0'        .ForeColor.Brightness = 0   '透明度设置 0.400000006=40%        .Transparency = 0        .SolidEnd WithEnd SubSub Chart_Transmit(ChartName As String, Gsht As Worksheet)Dim C As ChartObjectSet C = Gsht.ChartObjects(ChartName)With Gsht.Shapes(ChartName)      .Fill.ForeColor.RGB = RGB(63, 74, 92)'            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)'            .Line.ForeColor.RGB = RGB(255, 0, 0)'            .Line.ForeColor.ObjectThemeColor = msoThemeColorBackground1End WithWith C.chart.ChartArea      .Font.ColorIndex = 2      .Border.ColorIndex = 2End WithC.CopyPicture Appearance:=xlPrinter, Format:=xlPicture'     C.Chart.Export C.Name & ".JPG"  '导出到文件路径文件夹End SubSub ChartToPicture(ChartName As String, Gsht As Worksheet, Grng As Range)Dim C As ChartObjectGsht.SelectSet C = Gsht.ChartObjects(ChartName)C.CopyGrng.SelectGsht.PasteSpecial Format:="图片(JPEG)"Call ShapeCheck("P" & ChartName, Gsht)Selection.Name = "P" & ChartNameC.DeleteEnd SubSub ChartCheck(ChartName As String, Gsht As Worksheet)Dim R1, zstrDim C As ChartObjectR1 = Gsht.ChartObjects.CountIf R1 > 0 Then        For Each C In Gsht.ChartObjects            zstr = C.Name            If zstr = ChartName Then C.Delete        NextEnd IfEnd SubSub ShapeCheck(ShapeName As String, Gsht As Worksheet)Dim R1, zstrDim s As ShapeR1 = Gsht.Shapes.CountIf R1 > 0 Then        For Each s In Gsht.Shapes            zstr = s.Name            If zstr = ShapeName Then s.Delete        NextEnd IfEnd Sub'Sub Chart_XY_Axes()'第六部分：设置X\Y轴'myChart.Chart.Axes(xlCategory, xlPrimary).HasTitle = True   'XlCategory是X轴'mychart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "X轴标题"'With myChart.Chart.Axes(xlCategory, xlPrimary)'           .CrossesAt = 0'           .TickLabelSpacing = 1'           .TickMarkSpacing = 1'           .AxisBetweenCategories = True'           .ReversePlotOrder = False'End With'myChart.Chart.Axes(xlValue, xlPrimary).HasTitle = True      'xlValue是Y轴'myChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "项目数"    ''myChart.Chart.SetElement (msoElementPrimaryValueAxisTitleHorizontal)'With myChart.Chart.Axes(xlValue, xlPrimary)'            .MinimumScale = 0   '最小值'            .MaximumScale = 10     '最大值'            .MajorUnit = 2    '主要间距'            .MinorUnit = xlAutomatic    '次要间距'            .CrossesAt = 0      '坐标轴的交叉点'            .ReversePlotOrder = False'            .ScaleType = xlLinear'End With'第八部分：调整对比point的颜色'Dim ms As SeriesCollection'Set ms = myChart.Chart.SeriesCollection(1).points(1)'End Sub

Option Explicit
Sub group_by()
Application.ScreenUpdating = False
Dim sh_0 As WorksheetDim sh_1 As Worksheet        Call loading_data        Set sh_0 = ThisWorkbook.Sheets("res")    Set sh_1 = ThisWorkbook.Sheets("structure")            With sh_1        With .Cells            .Clear            .Font.Size = 9            .VerticalAlignment = xlCenter            .RowHeight = 16.25        End With        .Select        With .Rows(1)            .Font.Bold = True            .RowHeight = 22.75        End With                sh_0.Range("a:e").Copy        .Range("a1").PasteSpecial (xlPasteValues)    End With        Call melt    Call groupApplication.ScreenUpdating = True
End Sub
Sub loading_data()
Dim sql$Dim spath$Dim arrDim sht As Worksheet
    Set sht = ThisWorkbook.Sheets("res")    spath = ThisWorkbook.FullName    sql = "select tb_sort,表名,业务,按业务分类,指标数 from("    sql = sql + "Select tb_sort,表名,业务,按业务分类,count(1) as 指标数 ,b_sort,bc_sort from [indicator $] "    sql = sql + "group by tb_sort,表名,业务,按业务分类,b_sort,bc_sort "    sql = sql + "order by tb_sort ,b_sort,bc_sort) "
    arr = Extract(sql, spath)    With sht        .Cells.Clear        .Range("A1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr    End With
End Sub

Sub melt()
Dim nr, ncDim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("structure")    nc = sh.UsedRange.Columns.Count    sh.Cells.ClearOutline    sh.Range("a1:e1").Interior.Color = RGB(255, 217, 102)    Dim i, j, kDim ini_str, tmp_strDim tmp_c, tmp_endDim tmp_array
        tmp_array = Array(1, 3)    '    tmp_array = Array(4)    j = LBound(tmp_array)        Do While j <= UBound(tmp_array)            tmp_c = tmp_array(j)                i = 2        Select Case tmp_c                    Case Is < 3:                nr = sh.UsedRange.Rows.Count                Do While i <= nr                    If i = 2 Then                        ini_str = sh.Cells(i, tmp_c)                        With sh.Rows(i + 1)                            .Insert Shift:=xlDown                            sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)                            sh.Cells(i + 1, tmp_c + 3) = sh.Cells(i, tmp_c + 3)                            sh.Cells(i + 1, tmp_c + 4) = sh.Cells(i, tmp_c + 4)                            sh.Range(Cells(i, tmp_c + 2), Cells(i, tmp_c + 4)).Clear                        End With                        nr = nr + 1                        i = i + 1                    Else                        tmp_str = sh.Cells(i, tmp_c)                        If tmp_str = ini_str Then                            sh.Range(Cells(i, tmp_c), Cells(i, tmp_c + 1)).Clear                        Else                            ini_str = tmp_str                            With sh.Rows(i + 1)                                .Insert Shift:=xlDown                                sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)                                sh.Cells(i + 1, tmp_c + 3) = sh.Cells(i, tmp_c + 3)                                sh.Cells(i + 1, tmp_c + 4) = sh.Cells(i, tmp_c + 4)                                sh.Range(Cells(i, tmp_c + 2), Cells(i, tmp_c + 4)).Clear                            End With                            nr = nr + 1                            i = i + 1                        End If                    End If                    i = i + 1                Loop            Case Else:                nr = sh.UsedRange.Rows.Count                For k = 2 To nr                    If sh.Cells(k, tmp_c - 1) <> "" Then                        i = k + 1                        With sh.Cells(i, tmp_c)                            ini_str = .Value                            If .Offset(1, 0) = "" Then                                tmp_end = i                            Else                                tmp_end = .End(xlDown).Row                            End If                        End With                        Do While i <= tmp_end                            tmp_str = sh.Cells(i, tmp_c)                            If tmp_str = ini_str And i = k + 1 Then                                With sh.Rows(i + 1)                                    .Insert Shift:=xlDown                                    sh.Cells(i + 1, tmp_c + 1) = sh.Cells(i, tmp_c + 1)                                    sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)                                    sh.Range(Cells(i, tmp_c + 1), Cells(i, tmp_c + 2)).Clear                                End With                                i = i + 1                                nr = nr + 1                                tmp_end = tmp_end + 1                            Else                                If tmp_str = ini_str Then                                    sh.Cells(i, tmp_c).Clear                                Else                                    If tmp_str <> "" Then                                        ini_str = tmp_str                                        With sh.Rows(i + 1)                                            .Insert Shift:=xlDown                                            sh.Cells(i + 1, tmp_c + 1) = sh.Cells(i, tmp_c + 1)                                            sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)                                            sh.Range(Cells(i, tmp_c + 1), Cells(i, tmp_c + 2)).Clear                                        End With                                        nr = nr + 1                                        i = i + 1                                        tmp_end = tmp_end + 1                                    End If                                End If                            End If                            i = i + 1                        Loop                        k = i - 1                    End If                Next        End Select        j = j + 1    LoopEnd Sub

Sub group()
Dim sht As WorksheetDim row_start%, row_end%Dim target_column
    Set sht = Sheets("structure")    row_start = 2    target_column = "D"'    row_end = sht.Cells(1048576, target_column).End(xlUp).Row + 1    row_end = sht.UsedRange.Rows.Count        sht.Cells.ClearOutline
Dim iDim refer_row%

    i = row_start    refer_row = row_start    Do While i <= row_end        If Cells(i, 1) <> "" Then            With Range(Cells(i, 1), Cells(i, 5))                .Interior.Color = RGB(208, 206, 206)                .Font.Color = RGB(0, 0, 0)                .Font.Bold = True                With .Borders(xlEdgeTop)                    .LineStyle = xlDash                    .Color = RGB(166, 166, 166)                End With                With .Borders(xlEdgeBottom)                    .LineStyle = xlDash                    .Color = RGB(166, 166, 166)                End With                            End With        End If        If Cells(i, 3) <> "" Then            With Range(Cells(i, 3), Cells(i, 5))                .Interior.Color = RGB(255, 242, 204)                .Font.Color = RGB(0, 0, 0)                .Font.Bold = True                With .Borders(xlEdgeTop)                    .LineStyle = xlDash                    .Color = RGB(191, 191, 191)                End With                With .Borders(xlEdgeBottom)                    .LineStyle = xlDash                    .Color = RGB(191, 191, 191)                End With            End With        End If                If Cells(i, 4) <> "" Then            With Range(Cells(i, 4), Cells(i, 5))                .Interior.Color = RGB(255, 242, 204)                .Font.Color = RGB(0, 0, 0)                .Font.Bold = True                With .Borders(xlEdgeTop)                    .LineStyle = xlDash                    .Color = RGB(191, 191, 191)                End With                With .Borders(xlEdgeBottom)                    .LineStyle = xlDash                    .Color = RGB(191, 191, 191)                End With            End With        End If                If Cells(i, 5) <> "" Then            With Range(Cells(i, 5), Cells(i, 5))                With .Borders(xlEdgeTop)                    .LineStyle = xlDash                    .Color = RGB(128, 128, 128)                End With                With .Borders(xlEdgeBottom)                    .LineStyle = xlDash                    .Color = RGB(128, 128, 128)                End With            End With        End If                If Cells(i, 1) = "" Then Rows(i).group        i = i + 1    Loop
    For i = row_start To row_end        If Cells(i, 2) = "" And Cells(i, 3) = "" Then            Rows(i).group        End If    Next    '    For i = row_start To row_end'        If Cells(i, 3) = "" And Cells(i, 4) = "" Then'            Rows(i).group'        End If'    Next    End Sub