易坊好文馆

  1. 首页 > 生活百科 >

vba所有代码大全及语法 vba编程代码大全

生活百科 经验分享

一些常用的vba代码合集，方便检索引用
模块1：生成workbook下的目录
AttributeVB_Name = "Basic"OptionExplicitSubGenerate_Content_General()Application.ScreenUpdating= False'第一部分：声明基础变量Dimsht As WorksheetDimsht_content As WorksheetDimwk As WorkbookSetwk = ThisWorkbookSetsht_content = wk.Sheets("目录")Withsht_content.Cells(2, 2).Value= "http://www.siweifengbao.com/目录".Offset(0,1) = "超链接"EndWith'第二部分：超链接Dimi, j, kDimzstr, ystr, xstrj= 2i= 2DoWhile i < wk.Sheets.CountSetsht = wk.Sheets(i)Ifsht.Name <> "目录" And sht.Visible = -1 ThenWithsht_content.Cells(j + 1, 2).Value= http://www.siweifengbao.com/sht.Namesht_content.Hyperlinks.Add.Offset(0, 1), Address:="", SubAddress:="'" & sht.Name & "'!a1", TextToDisplay:="点击链接表"'逆向链接过程j= j + 1EndWithEndIfi= i + 1LoopWithsht_content.Range("b:c").Columns.AutoFit.Font.Size= 12EndWithApplication.ScreenUpdating= TrueEndSub 模块2：移动目录到第一个位置
Submove_sheet_index()Dimwb As WorkbookDimsht As WorksheetDimdht As WorksheetDimiDimsheet_nameDimindexSetwb = ThisWorkbookSetsht = wb.Sheets("目录")Fori = 2 To 38sheet_name= sht.Cells(i, 2)index= sht.Cells(i, 7)wb.Sheets(sheet_name).MoveAfter:=Sheets(i - 1)NextEndSub 模块3：更新目录
SubUpdate_Content()Application.ScreenUpdating= FalseDimwk As WorkbookDimsht_content As WorksheetSetwk = ThisWorkbookSetsht_content = wk.Sheets("目录")sht_content.Range("b:c").ClearContentsCallGenerate_Content_GeneralApplication.ScreenUpdating= TrueEndSub 模块4：取消隐藏单元格
SubCancel_Hidden()Dimsht As WorksheetForEach sht In Sheetssht.Visible= xlSheetVisibleNextEndSub 模块5：删除workbook下的代码模块
Sub删除代码() '这个程序要在标准的Moudle模块中Dimi, iconDimvbc As ObjectDimwk As WorkbookDimsht As WorksheetDimarrSetwk = ThisWorkbookSetsht = wk.Sheets("Draft")icon= wk.VBProject.VBComponents.CountReDimarr(1 To icon, 2)Fori = 1 To iconIfi > icon Then Exit ForSetvbc = wk.VBProject.VBComponents(i)'arr(i, 0) = i'arr(i, 1) = vbc.Name'arr(i, 2) = vbc.TypeIfvbc.Type = 1 And vbc.Name <> "Delete_Model" And vbc.Name <> "Func" ThenWithApplication.VBE.ActiveVBProject.VBComponents.Remove.Item(vbc.Name) '删除模块、类模块、窗体EndWithi= i - 1icon= icon - 1EndIfNext'sht.[a1].Resize(UBound(arr,1), UBound(arr, 2) + 1) = arrEndSub 模块6：vba中用sql模块
Functionexe_sql(ds, sql As String)Dimconn As ObjectDimspath$Dimi As Integer, j, k%, t As Integer, Trow%, Tcolumn%Dimcolumns, dataDimrst As ObjectSetconn = CreateObject("adodb.connection")Setrst = CreateObject("adodb.recordset")conn.Open"provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & dsIfsql = "" ThenMsgBox"请输入SQL语句"ExitFunctionElserst.Opensql, conn, 3i= rst.Fields.CountReDimcolumns(1 To i)'记录获取的列名Fork = 1 To icolumns(k)= rst.Fields(k - 1).NameNextIfrst.RecordCount > 0 Then j = rst.RecordCountReDimdata(1 To j, 1 To i)t= 1DoWhile rst.EOF = FalseFork = 1 To iIfNot IsNull(rst.Fields(k - 1)) Thendata(t,k) = rst.Fields(k - 1).ValueEndIfNextrst.movenextt= t + 1LoopEndIfexe_sql= Array(columns, data)EndFunction 模块7：通用的一些function
Function Extract(sql As String, f As String) '#@@ 拽数，并返回数组Dim cnn As Object, rst As Object Dim r_arr, arr Dim i, j '#@@@@# 大前提On Error GoTo Err_Handle If sql = "" Then Extract = 0: Exit Function '#@@@@# 正常执行Setcnn = CreateObject("adodb.connection") Setrst = 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, 3i = rst.RecordCount Ifi <> ""Andi >= 1Thenarr = rst.getrows(): rst.movefirst IfNotIsArray(arr) ThenExtract= Array("无记录"): ExitFunctionReDim 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 '#@@@@# 二维转换Forj = 0ToUBound(arr, 2) Fori = 0ToUBound(arr) r_arr(j + 1, i) = arr(i, j) NextNextExtract= 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.Description EndFunctionFunctionExtract_Origin(sqlAsString, f AsString) '#@@ 拽数，并返回数组 Dim cnn As Object, rst As Object Dim r_arr, arr Dim i, j '#@@@@# 大前提OnErrorGoToErr_Handle Ifsql= ""ThenExtract_Origin = 0: ExitFunction'#@@@@# 正常执行 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, 3Ifrst.RecordCount > 0Thenarr = rst.getrows ReDim r_arr(UBound(arr, 2), UBound(arr, 1)) Forj = 0ToUBound(arr, 2) Fori = 0ToUBound(arr) r_arr(j, i) = arr(i, j) NextNextElser_arr = 0EndIfExtract_Origin = r_arr rst.Close cnn.Close Setrst = NothingSetcnn = 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.Description EndFunctionFunctionCheckWkOpen(ByVal f) Dim tk AsWorkbook Dim statusstatus= 0ForEachtk InWorkbooks IfStrComp(f, "book1.xls", 1) = 0ThenMsgBox f & " is open"Application.Windows(f).Visible = TrueWorkbooks(f).Close Falsestatus= 1EndIfNextEndFunctionFunctionCheckFile(spath) Dim fso AsObjectSetfso = CreateObject("scripting.filesystemobject") CheckExists = fso.fileexists(spath) EndFunctionFunctionCheckTable(wk AsWorkbook, zstr AsString) Dim sht AsWorksheet Dim statusForEachsht Inwk.Sheets Ifsht.Name = zstr Thenstatus= 1ExitForElsestatus= 0EndIfNextCheckTable = statusEndFunctionSub tt() ActiveWorkbook.RemovePersonalInformation = FalseEndSub Function拽数(sqlAsString, f AsString) '@@拽数，并返回数组 Dim cnn As Object, rst As Object Dim r_arr, arr Dim 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 Function Err_Handle: Debug.Print Err.Description End Function 模块8：vba自动生成图表
AttributeVB_Name = "Generate_Chart"OptionExplicit'=======================================下面为VBA自动生成部分=======================================SubChart_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 存放大小DimXTitle, YTitleDimCrng As Range, Xrng As Range, rng As RangeDimsht As Worksheet, wb1 As WorkbookDimMyChart As ChartObjectDimR1, C, zstrSetwb1 = ThisWorkbookSetsht = wb1.Sheets("ChartData")R1= sht.ChartObjects.CountIfR1 > 0 ThenForEach C In sht.ChartObjectszstr= C.NameIfzstr = ChartName Then C.DeleteNextEndIf'第一部分：创建一个新的图表Object事件Setrng = sht.Cells(C_row, C_column)SetMyChart = sht.ChartObjects.Add(rng.Left, rng.Offset(1, 0).Top, rng.Width * C_width, rng.Height * C_height)WithMyChart.Name= ChartNameEndWith'第二部分：设置图表区格式WithMyChart.chart.ChartArea.Font.Name= "宋体".Font.Size= 8.Font.ColorIndex= xlAutomatic.Border.LineStyle= 0.Interior.ColorIndex= xlAutomatic '图表区填充EndWith'第三部分：设置绘图区格式WithMyChart.chart.PlotArea.Border.ColorIndex= 15.Border.Weight= xlThin'.Border.LineStyle = xlDot.Border.LineStyle= xlDot.Interior.ColorIndex= xlNone '绘图区填充EndWith'第五部分：设置图表标题MyChart.chart.HasTitle= TrueWithMyChart.chart.ChartTitle.Text= "<p>string</p>".Font.Name= "宋体".Font.Bold= True.Font.Size= 9.Top= 0EndWithEndSubSubChart_FillData(MyChart As ChartObject, SerieName As String, Xrng As Range, Yrng As Range)WithMyChart.chartDimnsSetns = .SeriesCollection.NewSeriesns.Values= XrngIfNot Yrng Is Nothing Then ns.XValues = Yrngns.Name= SerieNameEndWithEndSubSubChart_FinalStyle(MyChart As ChartObject)WithMyChart.chart'.ChartTitle.Left = (myChart.Chart.ChartArea.Width / 2) - (myChart.Chart.ChartTitle.Width / 2)EndWithEndSubSubChart_Axes(MyChart As ChartObject)MyChart.chart.Axes(xlValue).HasMajorGridlines= TrueWithMyChart.chart.Axes(xlValue).MajorGridlines.Border.ColorIndex= 15.Weight= xlHairline.LineStyle= xlDotEndWithEndSubSubChart_SeriesPoint(MyChart As ChartObject, S1)Dimms As SeriesCollectionMyChart.ActivateActiveChart.SeriesCollection(1).Points(S1).SelectWithSelection.Format.Fill.Visible= msoTrue.ForeColor.ObjectThemeColor= msoThemeColorAccent2.ForeColor.TintAndShade= 0'.ForeColor.Brightness = 0 '透明度设置 0.400000006=40%.Transparency= 0.SolidEndWithEndSubSubChart_Transmit(ChartName As String, Gsht As Worksheet)DimC As ChartObjectSetC = Gsht.ChartObjects(ChartName)WithGsht.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 = msoThemeColorBackground1EndWithWithC.chart.ChartArea.Font.ColorIndex= 2.Border.ColorIndex= 2EndWithC.CopyPictureAppearance:=xlPrinter, Format:=xlPicture'C.Chart.Export C.Name & ".JPG" '导出到文件路径文件夹EndSubSubChartToPicture(ChartName As String, Gsht As Worksheet, Grng As Range)DimC As ChartObjectGsht.SelectSetC = Gsht.ChartObjects(ChartName)C.CopyGrng.SelectGsht.PasteSpecialFormat:="图片(JPEG)"CallShapeCheck("P" & ChartName, Gsht)Selection.Name= "P" & ChartNameC.DeleteEndSubSubChartCheck(ChartName As String, Gsht As Worksheet)DimR1, zstrDimC As ChartObjectR1= Gsht.ChartObjects.CountIfR1 > 0 ThenForEach C In Gsht.ChartObjectszstr= C.NameIfzstr = ChartName Then C.DeleteNextEndIfEndSubSubShapeCheck(ShapeName As String, Gsht As Worksheet)DimR1, zstrDims As ShapeR1= Gsht.Shapes.CountIfR1 > 0 ThenForEach s In Gsht.Shapeszstr= s.NameIfzstr = ShapeName Then s.DeleteNextEndIfEndSub'SubChart_XY_Axes()'第六部分：设置X\Y轴'myChart.Chart.Axes(xlCategory,xlPrimary).HasTitle = True 'XlCategory是X轴'mychart.Chart.Axes(xlCategory,xlPrimary).AxisTitle.Text = "X轴标题"'WithmyChart.Chart.Axes(xlCategory, xlPrimary)'.CrossesAt = 0'.TickLabelSpacing = 1'.TickMarkSpacing = 1'.AxisBetweenCategories = True'.ReversePlotOrder = False'EndWith'myChart.Chart.Axes(xlValue,xlPrimary).HasTitle = True 'xlValue是Y轴'myChart.Chart.Axes(xlValue,xlPrimary).AxisTitle.Text = "项目数" ''myChart.Chart.SetElement(msoElementPrimaryValueAxisTitleHorizontal)'WithmyChart.Chart.Axes(xlValue, xlPrimary)'.MinimumScale = 0 '最小值'.MaximumScale = 10 '最大值'.MajorUnit = 2 '主要间距'.MinorUnit = xlAutomatic '次要间距'.CrossesAt = 0 '坐标轴的交叉点'.ReversePlotOrder = False'.ScaleType = xlLinear'EndWith'第八部分：调整对比point的颜色'Dimms As SeriesCollection'Setms = myChart.Chart.SeriesCollection(1).points(1)'EndSub 模块9：实现自动分级分组
【vba所有代码大全及语法 vba编程代码大全】OptionExplicitSubgroup_by()Application.ScreenUpdating= FalseDimsh_0 As WorksheetDimsh_1 As WorksheetCallloading_dataSetsh_0 = ThisWorkbook.Sheets("res")Setsh_1 = ThisWorkbook.Sheets("structure")Withsh_1With.Cells.Clear.Font.Size= 9.VerticalAlignment= xlCenter.RowHeight= 16.25EndWith.SelectWith.Rows(1).Font.Bold= True.RowHeight= 22.75EndWithsh_0.Range("a:e").Copy.Range("a1").PasteSpecial(xlPasteValues)EndWithCallmeltCallgroupApplication.ScreenUpdating= TrueEndSubSubloading_data()Dimsql$Dimspath$DimarrDimsht As WorksheetSetsht = ThisWorkbook.Sheets("res")spath= ThisWorkbook.FullNamesql= "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)Withsht.Cells.Clear.Range("A1").Resize(UBound(arr,1) + 1, UBound(arr, 2) + 1) = arrEndWithEndSubSubmelt()Dimnr, ncDimsh As WorksheetSetsh = ThisWorkbook.Sheets("structure")nc= sh.UsedRange.Columns.Countsh.Cells.ClearOutlinesh.Range("a1:e1").Interior.Color = RGB(255, 217, 102)Dimi, j, kDimini_str, tmp_strDimtmp_c, tmp_endDimtmp_arraytmp_array= Array(1, 3)'tmp_array = Array(4)j= LBound(tmp_array)DoWhile j <= UBound(tmp_array)tmp_c= tmp_array(j)i= 2SelectCase tmp_cCaseIs < 3:nr= sh.UsedRange.Rows.CountDoWhile i <= nrIfi = 2 Thenini_str= sh.Cells(i, tmp_c)Withsh.Rows(i + 1).InsertShift:=xlDownsh.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)).ClearEndWithnr= nr + 1i= i + 1Elsetmp_str= sh.Cells(i, tmp_c)Iftmp_str = ini_str Thensh.Range(Cells(i,tmp_c), Cells(i, tmp_c + 1)).ClearElseini_str= tmp_strWithsh.Rows(i + 1).InsertShift:=xlDownsh.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)).ClearEndWithnr= nr + 1i= i + 1EndIfEndIfi= i + 1LoopCaseElse:nr= sh.UsedRange.Rows.CountFork = 2 To nrIfsh.Cells(k, tmp_c - 1) <> "" Theni= k + 1Withsh.Cells(i, tmp_c)ini_str= .ValueIf.Offset(1, 0) = "" Thentmp_end= iElsetmp_end= .End(xlDown).RowEndIfEndWithDoWhile i <= tmp_endtmp_str= sh.Cells(i, tmp_c)Iftmp_str = ini_str And i = k + 1 ThenWithsh.Rows(i + 1).InsertShift:=xlDownsh.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)).ClearEndWithi= i + 1nr= nr + 1tmp_end= tmp_end + 1ElseIftmp_str = ini_str Thensh.Cells(i,tmp_c).ClearElseIftmp_str <> "" Thenini_str= tmp_strWithsh.Rows(i + 1).InsertShift:=xlDownsh.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)).ClearEndWithnr= nr + 1i= i + 1tmp_end= tmp_end + 1EndIfEndIfEndIfi= i + 1Loopk= i - 1EndIfNextEndSelectj= j + 1LoopEndSubSubgroup()Dimsht As WorksheetDimrow_start%, row_end%Dimtarget_columnSetsht = Sheets("structure")row_start= 2target_column= "D"'row_end = sht.Cells(1048576, target_column).End(xlUp).Row + 1row_end= sht.UsedRange.Rows.Countsht.Cells.ClearOutlineDimiDimrefer_row%i= row_startrefer_row= row_startDoWhile i <= row_endIfCells(i, 1) <> "" ThenWithRange(Cells(i, 1), Cells(i, 5)).Interior.Color= RGB(208, 206, 206).Font.Color= RGB(0, 0, 0).Font.Bold= TrueWith.Borders(xlEdgeTop).LineStyle= xlDash.Color= RGB(166, 166, 166)EndWithWith.Borders(xlEdgeBottom).LineStyle= xlDash.Color= RGB(166, 166, 166)EndWithEndWithEndIfIfCells(i, 3) <> "" ThenWithRange(Cells(i, 3), Cells(i, 5)).Interior.Color= RGB(255, 242, 204).Font.Color= RGB(0, 0, 0).Font.Bold= TrueWith.Borders(xlEdgeTop).LineStyle= xlDash.Color= RGB(191, 191, 191)EndWithWith.Borders(xlEdgeBottom).LineStyle= xlDash.Color= RGB(191, 191, 191)EndWithEndWithEndIfIfCells(i, 4) <> "" ThenWithRange(Cells(i, 4), Cells(i, 5)).Interior.Color= RGB(255, 242, 204).Font.Color= RGB(0, 0, 0).Font.Bold= TrueWith.Borders(xlEdgeTop).LineStyle= xlDash.Color= RGB(191, 191, 191)EndWithWith.Borders(xlEdgeBottom).LineStyle= xlDash.Color= RGB(191, 191, 191)EndWithEndWithEndIfIfCells(i, 5) <> "" ThenWithRange(Cells(i, 5), Cells(i, 5))With.Borders(xlEdgeTop).LineStyle= xlDash.Color= RGB(128, 128, 128)EndWithWith.Borders(xlEdgeBottom).LineStyle= xlDash.Color= RGB(128, 128, 128)EndWithEndWithEndIfIfCells(i, 1) = "" Then Rows(i).groupi= i + 1LoopFori = row_start To row_endIfCells(i, 2) = "" And Cells(i, 3) = "" ThenRows(i).groupEndIfNext'For i = row_start To row_end'If Cells(i, 3) = "" And Cells(i, 4) = "" Then'Rows(i).group'End If'NextEndSub

    推荐阅读


    上一篇：哪些动物是畜生

    下一篇：556是什么意思网络用语