VBA常用技巧代码解析

csword2005 · 发表于 2009-7-2 09:55

感激之情都不知道怎么说了~

wingedlion · 发表于 2009-7-2 09:56

感谢感谢。。。。。

xtec2525 · 发表于 2009-7-2 14:59

系统学习一下，受益非浅，非常感谢版主的无私和辛勤的劳动。

cliffordzk · 发表于 2009-7-2 15:12

这个太好了。

yuanzhuping · 发表于 2009-7-2 16:12

技巧194 制作发放条
虽然大多数企业的工资核算都已使用了专业软件，但是有些不能上工资表的项目还是需要使用Excel来制作发放表，比如如图所示的奖金发放表，这时往往需要提供发放条给每一个职工。

制作发放条的方法有很多，其中使用VBA制作发放条是最方便快捷的，如下面的代码所示。

#001 Sub Printissued()
#002 Dim r As Integer
#003 Dim Sh As Worksheet
#004 Dim i As Integer
#005 Application.ScreenUpdating = False
#006 r = Sheet1.Range("B65536").End(xlUp).Row
#007 With Worksheets
#008 Set Sh = .Add(after:=Worksheets(.Count))
#009 End With
#010 With Sh
#011 Sheet1.Range("A1:K" & r).Copy .Range("A1")
#012 .Range("A5:K" & r) = Sheet1.Range("A5:K" & r).Value
#013 .Range("F2,K2") = ""
#014 With .PageSetup
#015 .PrintTitleRows = "$1:$1"
#016 .LeftMargin = Application.CentimetersToPoints(1)
#017 .RightMargin = Application.CentimetersToPoints(1)
#018 .CenterHorizontally = True
#019 End With
#020 For i = 1 To r
#021 .Rows(i).RowHeight = Sheet1.Rows(i).RowHeight
#022 Next
#023 For i = 1 To 11
#024 Columns(i).ColumnWidth = Sheet1.Columns(i).ColumnWidth
#025 Next
#026 r = .Range("B65536").End(xlUp).Row
#027 For i = r To 6 Step -1
#028 .Rows("2:4").Copy
#029 .Rows(i).Insert Shift:=xlDown
#030 Next
#031 Application.CutCopyMode = False
#032 ActiveWindow.View = xlPageBreakPreview
#033 For i = 1 To .HPageBreaks.Count
#034 If .HPageBreaks(i).Location.Offset(-1, 0) <> "" Then
#035 .HPageBreaks.Add Before:=.HPageBreaks(i).Location.Offset(-2, 0)
#036 End If
#037 Next
#038 ActiveWindow.View = xlNormalView
#039 .PrintOut
#040 Application.DisplayAlerts = False
#041 .Delete
#042 Application.DisplayAlerts = True
#043 End With
#044 Application.ScreenUpdating = True
#045 End Sub

复制代码

代码解析：
   Printissued过程将发放表以发放条的形式打印。
   第5行代码关闭屏幕刷新加快运行速度。
   第7行到第9行代码，为了不破坏原表的结构，在工作簿中新建一张工作表用来制作发放条。
   第11行代码，将发放表中需要制作发放条的区域拷贝到新工作表中。
   第12行代码，将表中的公式部分转化为数值。
   第13行代码，删除原表中的年度和人数。
   第14行到第19行代码，设置发放条表的打印标题行、左右边距及水平居中。
   第20行到第25行代码，设置发放条表的行高列宽与原表一致。
   第26行到第31行代码，在发放条的每行数据前插入表头部分。
   第32行到第38行代码，因为可能存在同一个人表头和数据不在同一页面的现象，所以逐一检查分页符，如果分页符所在单元格的上面单元格不是空白行则将分页符上移两行。
   第39行代码，使用PrintOut方法打印发放条。
   第40行到第42行代码，使用Delete方法删除发放条表。
   运行Printissued过程，发放条表没删除前如图所示。

向東 · 发表于 2009-7-2 18:19

楼主加油继续更新

yuanzhuping · 发表于 2009-7-3 08:25

技巧195 费用统计表
对于经常发生的一些费用开支，可以使用Excel进行录入和统计，比如使用本统计表可以方便的录入汽车费用明细，对费用明细按时间或类别进行统计，并以图表的形式在窗体中显示出来。
步骤1，新建工作簿，将Sheet1表重命名为“费用明细”并设置为如图所示的格式。

步骤2，在Sheet1工作表中单击菜单“视图”→“工具栏”→“控件工具箱”，在显示的工具栏中选择“其他附件”中的DTPicker控件，在工作表中拖动添加一个DTPicker控件。如果“其他附件”中没有该控件，请参阅技巧118 对其进行注册。
步骤3，在VBE中双击Sheet1，在工作表的SelectionChange事件过程中写入以下代码。

#001 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
#002 Dim r As Integer
#003 r = Sheet1.Range("B65536").End(xlUp).Row
#004 If Target.Row > 1 And Target.Row < r And Target.Count = 1 Then
#005 If Target.Column = 1 Then
#006 With Me.DTPicker1
#007 .Visible = True
#008 .Value = Date
#009 .Top = Target.Top
#010 .Left = Target.Left
#011 .Width = Target.Width + 15
#012 .Height = Target.Height
#013 End With
#014 Else
#015 Me.DTPicker1.Visible = False
#016 End If
#017 If Target.Column = 3 Then
#018 With Target.Validation
#019 .Delete
#020 .Add Type:=xlValidateList, _
#021 AlertStyle:=xlValidAlertStop, _
#022 Operator:=xlBetween, _
#023 Formula1:="汽油费,过路费,保险费,修理费,保养费,装饰费,改装费,养路费,其他费"
#024 End With
#025 End If
#026 End If
#027 End Sub

复制代码

代码解析：
   工作表的SelectionChange事件，当选择A列单元格时显示日历控件，选择C列时建立数据有效性，便于在工作表中录入时间及费用类别。
   第4行代码，设置该事件的触发条件，只有在选择第2行和“合计”行之间单元格并且只选择一个单元格时事件触发。
   第5行到第16行代码如果选择的是第一列录入日期的单元格时，显示日历控件并对其格式进行相应的设置，如图所示，方便录入费用日期，否则隐藏日历控件。

第17行到第26行代码如果选择的是第三列录入费用类别的单元格时，在单元格中建立数据有效性设置，如图所示。关于在工作表中建立数据有效性请参阅12-1。

在VBE中双击Sheet1，在工作表的Change事件过程中写入以下代码。

#001 Private Sub Worksheet_Change(ByVal Target As Range)
#002 Dim r1 As Integer
#003 Dim r2 As Integer
#004 With Sheet1
#005 r1 = .Range("D65536").End(xlUp).Row
#006 r2 = .Range("E65536").End(xlUp).Row
#007 If Target.Column = 4 And Target.Row > 1 And Target.Count = 1 Then
#008 .Range("E2:E" & r1).FormulaR1C1 = "=SUM(R2C4:RC4)"
#009 .Range("E2:E" & r1) = Range("E2:E" & r1).Value
#010 .Cells(r2, 5).FormulaR1C1 = "=SUM(R2C4:RC4)"
#011 .Cells(r2, 5) = .Cells(r2, 5).Value
#012 End If
#013 End With
#014 End Sub

复制代码

代码解析：
工作表的Change事件过程，当工作表的第四列单元格中录入费用金额时，在第五列“合计”单元格中写入金额合计的公式，并将公式转化为数值。
在设计模式下双击DTPicker控件，写入下面的代码。

#001 Private Sub DTPicker1_CloseUp()
#002 ActiveCell = DTPicker1.Value
#003 DTPicker1.Visible = False
#004 End Sub

复制代码

代码解析：
DTPicker控件的Change事件，选择日历控件的日期时将日期写入到工作表的活动单元格中。
步骤4，在VBE窗口中单击菜单“插入”→“用户窗体”，添加一个“统计”窗体，在窗体中添加一个ListView和一个框架控件控件，在框架控件中添加三个组合框控件、三个按钮控件和一个框架控件，在其中添加一个标签控件，如图所示。

在VBE中双击窗体写入下面的代码。

#001 Private Sub UserForm_Initialize()
#002 Dim Col As New Collection
#003 Dim rng As Range, arr, Category
#004 Dim i As Integer
#005 On Error Resume Next
#006 For Each rng In Sheet1.Range("A2:A" & [A65536].End(xlUp).Row)
#007 Col.Add Left(rng, 7), Key:=CStr(Left(rng, 7))
#008 Next
#009 ReDim arr(1 To Col.Count)
#010 For i = 1 To Col.Count
#011 arr(i) = Col(i)
#012 Next
#013 Me.Frame1.ComboBox1.List = arr
#014 Me.Frame1.ComboBox2.List = arr
#015 Category = Array("汽油费", "过路费", "保险费", "修理费", "保养费", "装饰费", "其他费")
#016 Me.Frame1.ComboBox3.List = Category
#017 With Me.ListView1
#018 .ColumnHeaders.Clear
#019 .ColumnHeaders.Add , , " 日期", 55, lvwColumnLeft
#020 .ColumnHeaders.Add , , " 费用内容", 110, lvwColumnLeft
#021 .ColumnHeaders.Add , , "费用类别", 50, lvwColumnCenter
#022 .ColumnHeaders.Add , , "金额 ", 50, lvwColumnRight
#023 .ColumnHeaders.Add , , "合计 ", 60, lvwColumnRight
#024 .View = lvwReport
#025 .Gridlines = True
#026 End With
#027 Me.CommandButton3.Enabled = False
#028 End Sub

复制代码

代码解析：
   窗体的Initialize事件，窗体初始化时对其中的控件进行相应的设置。
   第6行到第14行代码，使用Add方法将第一列中的日期去除重复值后取其年月添加到“开始日期”和“结束日期”组合框中，关于使用Add方法去除重复值请参阅技巧110 。
   第15、16行代码在“费用类别”组合框中添加列表项。关于在组合框中添加列表项的方法请参阅技巧109 。
   第17行到第26行代码在ListView控件中添加标题列并进行相应的设置，请参阅技巧131 。
   第27行代码将“图表”按钮的Enabled属性设置为False，使之暂不可用。
   在VBE中双击窗体上的“统计”按钮写入下面的代码。

#001 Private Sub CommandButton1_Click()
#002 Dim StartDate As Date
#003 Dim EndDate As Date
#004 Dim r As Integer
#005 Dim r2 As Integer
#006 Dim Itm As ListItem
#007 Dim i As Integer
#008 Dim Col As New Collection
#009 Dim rng As Range
#010 Dim StrResults As String
#011 r = Sheet1.Range("A65536").End(xlUp).Row
#012 With Me.Frame1.ComboBox1
#013 If .Value = "" Then
#014 StartDate = .List(0) & "-1"
#015 Else
#016 StartDate = .Value & "-1"
#017 End If
#018 End With
#019 With Me.Frame1.ComboBox2
#020 If .Value = "" Then
#021 EndDate = DateSerial(Year(.List(.ListCount - 1) & "-1"), Month(.List(.ListCount - 1) & "-1") + 1, 0)
#022 Else
#023 EndDate = DateSerial(Year(.Value & "-1"), Month(.Value & "-1") + 1, 0)
#024 End If
#025 End With
#026 If StartDate > EndDate Then
#027 MsgBox "开始日期不能大于结束日期,请重新选择!", , "提示"
#028 Exit Sub
#029 End If
#030 If Me.Frame1.ComboBox3 = "" Then
#031 Me.CommandButton3.Enabled = True
#032 Else
#033 Me.CommandButton3.Enabled = False
#034 End If
#035 Application.ScreenUpdating = False
#036 Sheet1.Range("A1:E" & r).AutoFilter Field:=1, Criteria1:=">=" & StartDate, Criteria2:="<=" & EndDate
#037 If Me.Frame1.ComboBox3 <> "" Then
#038 Sheet1.Range("A1:E" & r).AutoFilter Field:=3, Criteria1:=Me.Frame1.ComboBox3.Value
#039 End If
#040 With Sheet2
#041 .Cells.Clear
#042 Sheet1.AutoFilter.Range.SpecialCells(12).Copy .Cells(1, 1)
#043 r2 = .Range("A65536").End(xlUp).Row
#044 If r2 > 1 Then
#045 .Range("E2:E" & r2).FormulaR1C1 = "=SUM(R2C4:RC4)"
#046 .Range("E2:E" & r2) = .Range("E2:E" & r2).Value
#047 End If
#048 End With
#049 Sheet1.Range("A1:E" & r).AutoFilter
#050 With Me.ListView1
#051 .ListItems.Clear
#052 For i = 2 To r2
#053 Set Itm = .ListItems.Add()
#054 With Sheet2
#055 Itm.Text = .Cells(i, 1)
#056 Itm.SubItems(1) = .Cells(i, 2)
#057 Itm.SubItems(2) = .Cells(i, 3)
#058 Itm.SubItems(3) = Format(.Cells(i, 4), "0.00")
#059 Itm.SubItems(4) = Format(.Cells(i, 5), "0.00")
#060 End With
#061 Next
#062 End With
#063 On Error Resume Next
#064 Sheet3.Range("A1:B30").Clear
#065 If r2 > 1 Then
#066 For Each rng In Sheet2.Range("C2:C" & r2)
#067 Col.Add rng, Key:=CStr(rng)
#068 Next
#069 For i = 1 To Col.Count
#070 With Sheet3
#071 .Cells(i, 1) = Col(i)
#072 .Cells(i, 2).FormulaR1C1 = "=SUMIF(统计数据!R2C[1]:R" & r2 & "C[1],RC[-1],统计数据!R2C[2]:R" & r2 & "C[2])"
#073 .Cells(i, 2) = .Cells(i, 2).Value
#074 StrResults = StrResults & Space(2) & .Cells(i, 1) & "：" & Space(3) & .Cells(i, 2) & "元" & Chr(13)
#075 End With
#076 Next
#077 Label4.Caption = Space(2) & StartDate & " 至：" & Chr(13) & Space(2) & EndDate & " 期间" & Chr(13) & StrResults & Space(2) & "合计：" & Space(3) & Sheet2.Cells(r2, 5).Value & "元"
#078 Else
#079 Label4.Caption = Space(2) & StartDate & " 至：" & Chr(13) & Space(2) & EndDate & " 期间" & Chr(13) & Space(2) & Me.Frame1.ComboBox3.Value & "没有发生!"
#080 End If
#081 Application.ScreenUpdating = True
#082 End Sub

复制代码

代码解析：
   窗体上的“统计”按钮的单击事件，按日期统计费用类型和金额并显示在ListView控件中。
   第12行到第18行代码取得需要统计的开始日期，如果没有选择开始日期则默认为工作表中已录入日期的第一个月的第一天。
   第19行到第25行代码取得需要统计的结束日期，如果没有选择结束日期则默认为工作表中已录入日期的最后一个月的最后一天。
   第26行到第29行代码检查开始日期和结束日期，开始日期不能大于结束日期，否则无法正确统计数据。
   第30行到第34行代码设置“图表”按钮的Enabled属性，如果没有选择“费用类别”说明统计的是全部类别，则“图表”按钮有效；如果选择了“费用类别”中的明细类别，则不需要“图表”按钮，因为单一的费用类别是不需要使用图表进行分析的。
   第36行代码对工作表中的数据进行自定义筛选，筛选出介于所选开始日期和结束日期之间的数据。
   第37行到第39行代码如果同时选择了“费用类别”中的明细类别，则对工作表中筛选出来的数据进行第二次筛选，筛选出该类别的数据。
   第40行到第48行代码将筛选结果复制到Sheet2工作表中，请参阅技巧36 。
   第49行代码取消筛选模式。
   第50行到第62行代码将Sheet2工作表中的筛选结果显示到窗体的ListView控件中。关于ListView控件请参阅技巧131 。
   第63行到第68行代码将Sheet2工作表中的筛选结果中的C列中的明细类别使用使用Add方法去除重复值。请参阅技巧110 。
   第69行到第80行代码在Sheet3工作表A列中写入类别明细并在B列中写入SUMIF函数计算该费用类别在统计时段中的合计发生费用，并将公式转化为数值。最后使用标签将类别明细和费用金额显示有窗体中。
   在VBE中双击窗体上的“图表”按钮写入下面的代码。

#001 Private Sub CommandButton3_Click()
#002 Dim r As Integer
#003 Dim myRange As Range
#004 Dim myChart As ChartObject
#005 Application.ScreenUpdating = False
#006 With Sheet3
#007 r = .Range("A65536").End(xlUp).Row
#008 .ChartObjects.Delete
#009 Set myRange = .Range("A" & 1 & ":B" & r)
#010 Set myChart = .ChartObjects.Add(120, 40, 400, 250)
#011 With myChart.Chart
#012 .ChartType = xlPie
#013 .SetSourceData Source:=myRange, PlotBy:=xlColumns
#014 .Location xlLocationAsObject, "统计图表"
#015 .Legend.Position = -4152
#016 .Legend.Font.Size = 9
#017 .PlotArea.Interior.ColorIndex = -4142
#018 .PlotArea.Border.LineStyle = -4142
#019 .SeriesCollection(1).ApplyDataLabels _
#020 AutoText:=True, _
#021 HasLeaderLines:=True, _
#022 ShowValue:=True, _
#023 ShowCategoryName:=True, _
#024 ShowPercentage:=True
#025 .SeriesCollection(1).DataLabels.Font.Size = 9
#026 End With
#027 Set myChart = Nothing
#028 End With
#029 Sheet1.Select
#030 Application.ScreenUpdating = True
#031 UserForm2.Show
#032 End Sub

复制代码

代码解析：
   窗体中“图表”按钮的单击事件，在Sheet3工作表中根据统计数据建立图表。
   第8行代码，首先删除工作表原有的图表。
   第10行代码，在Sheet3表中建立新的图表。
   第11行到第26行代码，对新建立的图表进行格式设置。关于图表请参阅技巧60 。
   第31行代码显示图表窗体。

yuanzhuping · 发表于 2009-7-3 08:29

步骤5，在VBE窗口中单击菜单“插入”→“用户窗体”，添加一个“图表”窗体，在窗体中添加一个Image控件和一个按钮控件，如图所示。

在VBE中双击窗体，写入下面的代码。

#001 Private Sub UserForm_Initialize()
#002 Dim Charts As Chart
#003 Dim cName As String
#004 Set Charts = Sheet3.ChartObjects(1).Chart
#005 cName = ThisWorkbook.Path & "\Temp.gif"
#006 Charts.Export Filename:=cName, FilterName:="GIF"
#007 Image1.Picture = LoadPicture(cName)
#008 End Sub
#009 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
#010 Kill ThisWorkbook.Path & "\Temp.gif"
#011 End Sub
#012 Private Sub CommandButton1_Click()
#013 Unload Me
#014 End Sub

复制代码

代码解析：
   第1行到第8行代码是窗体的Initialize事件，在窗体初始化时将工作表中的图表显示在窗体中。
   第9行到第11行代码是窗体的QueryClose事件，在窗体关闭时删除临时文件。
   关于将图表显示在窗体上的方法请参阅技巧146-1。
   步骤6，为了方便使用，需要在菜单栏上添加自定义菜单，在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码。

#001 Sub AddNewMenu()
#002 Dim HelpMenu As CommandBarControl
#003 Dim NewMenu As CommandBarPopup
#004 With Application.CommandBars("Worksheet menu bar")
#005 .Reset
#006 Set HelpMenu = .FindControl(ID:=.Controls("帮助(&H)").ID)
#007 If HelpMenu Is Nothing Then
#008 Set NewMenu = .Controls.Add(Type:=msoControlPopup)
#009 Else
#010 Set NewMenu = .Controls.Add(Type:=msoControlPopup, _
#011 Before:=HelpMenu.Index)
#012 End If
#013 With NewMenu
#014 .Caption = "汽车费用(&S)"
#015 With .Controls.Add(Type:=msoControlButton)
#016 .Caption = "批量插入空行(&D)"
#017 .FaceId = 162
#018 .OnAction = "InSertRows"
#019 End With
#020 With .Controls.Add(Type:=msoControlButton)
#021 .Caption = "汽车费用统计(&T)"
#022 .FaceId = 590
#023 .OnAction = "Form"
#024 End With
#025 End With
#026 End With
#027 Set HelpMenu = Nothing
#028 Set NewMenu = Nothing
#029 End Sub

复制代码

#030 Sub DelNewMenu()
#031 Application.CommandBars("Worksheet menu bar").Reset
#032 End Sub
#033 Sub Form()
#034 UserForm1.Show
#035 End Sub
#036 Sub InSertRows()
#037 Dim dInput As Byte
#038 Dim i As Byte
#039 Dim r As Integer
#040 r = Sheet1.Range("B65536").End(xlUp).Row
#041 dInput = Application.InputBox(Prompt:="请输入插入的行数：", Title:="批量插入空行", Type:=1)
#042 If dInput <> False Then
#043 Application.ScreenUpdating = False
#044 For i = 1 To dInput
#045 Sheet1.Rows(r).Insert
#046 Next
#047 Application.ScreenUpdating = True
#048 End If
#049 End Sub

复制代码

代码解析：
   AddNewMenu过程在菜单栏的帮助菜单前添加“汽车费用”菜单。
   DelNewMenu过程删除添加的“汽车费用”菜单。
   Form过程是“汽车费用”菜单中的子菜单“汽车费用统计”所运行的宏过程，显示“图表”窗体。
   关于在工作表菜单栏中添加自定义菜单请参阅技巧80 。
I    nSertRows过程是“汽车费用”菜单中的子菜单“批量插入空行”所运行的宏过程，使用InputBox方法显示一个对话框，输入需要插入的行数后使用Insert方法在工作表中插入空行。
   关于InputBox方法请参阅技巧76 ，关于Insert方法请参阅技巧30 。
   为了在打开工作簿时自动添加菜单项，需要在工作簿的Activate事件中调用myTools过程，如下面的代码所示。

#001 Private Sub Workbook_Activate()
#002 Call AddNewMenu
#003 End Sub

复制代码

为了在关闭工作簿时删除新添加的菜单项，还需要在工作簿的Deactivate事件中调用DelmyTools过程，如下面的代码所示。

#001 Private Sub Workbook_Deactivate()
#002 Call DelNewMenu
#003 End Sub

复制代码

步骤7，因为在平时使用时是不需要操作Sheet2表和Sheet3表的，在VBE中分别选择Sheet2表和Sheet3表的属性窗口，将Visible设置为xlSheetVeryHidden，使工作表深度隐藏，这样在“格式”菜单中就不能取消隐藏。
保存关闭工作簿，重新打开工作簿，在费用明细表中录入数据后，点击“汽车费用”菜单后显示“费用统计”窗体，选择统计条件后即能统计出明细费用，如图所示。

此时单击窗体中的“图表”按钮将用窗体显示该期间费用的图表，如图所示。

789789i · 发表于 2009-7-3 08:55

感谢!!!!!!!!!!!!!

nowarmy · 发表于 2009-7-3 09:45

楼主辛苦了，麻烦回答一个问题。
如何删除指定文件内的所有宏代码（包括窗体、控件、模块等）？
楼主根据技巧188-4中内容修改一下。
谢谢！

		自动登录	找回密码
密码			免费注册

VBA常用技巧代码解析

第11部分其他应用

第11部分其他应用

评分

回复 1273楼 yuanzhuping 的帖子

VBA常用技巧代码解析

第11部分 其他应用

第11部分 其他应用

评分

回复 1273楼 yuanzhuping 的帖子

第11部分其他应用

第11部分其他应用