1sub 新建()
2    Sheets.add after:=sheets(sheets.count)
3    sheets(sheets.count).name="工作表" '工作表命名'
4end sub

 1Sub 生成()
 2Application.DisplayAlerts = False
 3
 4Dim i As Integer
 5For i = 1 To InputBox("生成工作表个数")
 6    Worksheets(1).Copy after:=Worksheets(Worksheets.Count)
 7    Worksheets(Worksheets.Count).Name = "12月" & i & "日"
 8    Worksheets(Worksheets.Count).Range("A1") = "12月" & i & "日"
 9Next
10Worksheets(1).Select
11Application.DisplayAlerts = True
12End Sub

1Sub 清除()
2Application.DisplayAlerts = False
3Do While Worksheets.Count <> 1
4    Worksheets(Worksheets.Count).Delete
5Loop
6Application.DisplayAlerts = True
7End Sub

 1Sub CreateMenu()
 2Sheets.Add(Before:=Sheets(1)).Name = "目录"  '新建一个目录工作表
 3Worksheets("目录").Activate
 4    For i = 2 To Sheets.Count
 5        If Sheets(i).Visible = True Then
 6            Cells(i, 1) = Sheets(i).Name  '将其他工作表名称分别填入单元格中
 7            Cells(i, 1).Select
 8                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=Cells(i, 1).Value
 9                '创建超链接
10        End If
11    Next i
12End Sub

 1Sub 拆分()
 2Application.ScreenUpdating = False
 3Dim sht As Worksheet
 4For Each sht In Worksheets
 5    sht.Copy
 6    ActiveWorkbook.SaveAs Filename:="C:\Users\lei\Desktop\T\" & sht.Name & ".xlsx"
 7    ActiveWorkbook.Close
 8Next
 9Application.ScreenUpdating = True
10End Sub

 1[a10]  		'a10单元格，不支持变量'
 2cells(2,3) 	'第二行第三列，只能选择一个格子，支持变量'
 3range("a10")	'a10单元格，应用场景广泛'
 4range("a10").value	'单元格默认属性为 .value，大多情况可以省略'
 5
 6range("a1").offset(10,0) '下移10行，右移0列'
 7range("a1000").end(xlUP).Row	'表示a1000单元格往上第一个有数据的格子的行号，.Row返回单元格行号'
 8
 9range("a10").EntireRow	'a10 单元格所在的整行'
10range("a10").resize(1,4)  '重新选择a10单元格区域大小'
11
12range("a10:f10").copy range("a11")		'将a10:f10区域，复制到a11'
13
14range("a10:f10").Merge	'将a10:f10区域合并'

 1Sub 拆分()
 2    '工作表建好了情况下，固定列，该段代码仅供参考，通过循环'
 3Dim i, j, k As Integer
 4Call 清空   '调用 清空 这个过程
 5For j = 2 To Sheets.Count
 6    For i = 2 To Sheets(1).Range("a10000").End(xlUp).Row
 7        If Sheets(1).Range("d" & i) = Sheets(j).Name Then
 8            k = Sheets(j).Range("a10000").End(xlUp).Row
 9            Sheets(1).Range("d" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)
10        End If
11    Next
12Next
13End Sub
14
15Sub 清空()
16    For i = 2 To Sheets.Count
17        Sheets(i).Range("a2:f1000").ClearContents
18    Next
19End Sub

 1Sub 拆分()
 2    '工作表建好了情况下，固定列，效率比for循环高很多
 3    Dim i As Integer
 4    Call 清空
 5    For i = 2 To Sheets.Count
 6        Sheets(1).Range("A1:F1048").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
 7        Sheets(1).Range("A1:F1048").Copy Sheets(i).Range("a2")
 8    Next
 9    Sheets(1).Range("A1:F1048").AutoFilter  '''取消筛选
10End Sub
11Sub 清空()
12        For i = 2 To Sheets.Count
13            Sheets(i).Range("a2:f1000").ClearContents
14        Next
15End Sub

 1Sub 根据某列建表并复制数据()
 2'重点 
 3'1.新建表避免表名重复
 4'2.通过用户输入 根据哪列进行拆分
 5'3.通过筛选将相应的数据拷贝到对应工作表
 6Application.DisplayAlerts = False
 7Dim sht As Worksheet
 8Dim i, irow, j, k As Integer
 9Dim a As Range
10Dim l As Integer '按哪列拆分
11l = InputBox("请输入按哪列拆分（输入数字）")
12irow = Sheets(1).Range("a10000").End(xlUp).Row '数据行
13
14'删除多余工作表
15For j = 2 To Sheets.Count
16    Sheets(Sheets.Count).DrawingObjects.Delete
17Next
18
19'根据列拆分表
20For i = 2 To irow
21    k = 0
22    Set a = Worksheets(1).Cells(i, l)
23    For Each sht In Sheets
24        If sht.Name = a Then
25            k = 1
26        End If
27    Next
28    If k = 0 Then
29        Sheets.Add after:=Sheets(Sheets.Count)
30        Sheets(Sheets.Count).Name = a.Value
31    End If
32Next
33
34'通过筛选复制数据
35For j = 2 To Sheets.Count
36    Sheets(1).Range("a1:f" & irow).AutoFilter field:=l, Criteria1:=Sheets(j).Name   'field:=l 筛选哪一列(这里是变量 l)
37    Sheets(1).Range("a1:f" & irow).Copy Sheets(j).Range("a2")
38Next
39Sheets(1).Range("a1:f" & irow).AutoFilter
40Sheets(1).Select
41Application.DisplayAlerts = True	
42End Sub

 1Sub 合并多表()
 2Dim sht As Worksheet
 3Dim i, j As Integer
 4For Each sht In Sheets
 5    i = Sheets(1).Range("a10000").End(xlUp).Row
 6    j = sht.Range("a10000").End(xlUp).Row
 7    If sht.Name <> Sheets(1).Name Then
 8        sht.Range("a2:f" & j).Copy Sheets(1).Range("a" & i + 1) '最后数据行下面粘贴
 9    End If
10Next
11End Sub

 1'字体格式选项卡'
 2With Selection.Font
 3    .Name = "华文琥珀"		'字体'
 4    .Size = 9		'字号'
 5    .Strikethrough = False		'删除线'
 6    .Superscript = False		'上标'
 7    .Subscript = False		'下标'
 8    .OutlineFont = False		'大纲字体'
 9    .Shadow = False		'阴影'
10    .Underline = xlUnderlineStyleNone		'下划线'
11    .ColorIndex = xlAutomatic		'字体颜色'
12    .TintAndShade = 0		'字体颜色变深或变浅'
13    .ThemeFont = xlThemeFontNone		'主题字体'
14End With
15
16'填充色选项卡'
17 With Selection.Interior
18    .Pattern = xlSolid		'图案样式'
19    .PatternColorIndex = xlAutomatic	'图案颜色'
20    .ThemeColor = xlThemeColorDark1		'主题颜色'
21    .TintAndShade = 0		'颜色变深或变浅'
22    .Color = 65535		'填充色'
23    .PatternTintAndShade = 0		'对象的单色和底纹图案'
24End With

1'标亮选中行，工作表事件，当选取发生变化自动执行以下代码'
2Private Sub Worksheet_SelectionChange(ByVal Target As Range)	'选区变换执行'
3    Cells.Interior.Pattern = xlNone
4    With Selection.EntireRow.Interior
5        .Pattern = xlSolid
6        .PatternColorIndex = xlAutomatic
7        .Color = 65535
8    End With
9End Sub

 1'通过单元格内容筛选某列，并自动更新'
 2Private Sub Worksheet_Change(ByVal Target As Range)	'工作表内容变化执行'
 3    Application.EnableEvents = False    '关闭事件响应，否则此段代码会卡死
 4    Dim i, j As Integer
 5    i = ActiveSheet.Range("a10000").End(xlUp).Row    '数据行数量
 6    j = ActiveSheet.Range("l10000").End(xlUp).Row   '筛选出来的数据行数量
 7    ActiveSheet.Range("l1:q" & j).ClearContents     '清除筛选出来的数据
 8    ActiveSheet.Range("A1:F" & i).AutoFilter Field:=4, Criteria1:=Range("i2")
 9    ActiveSheet.Range("A1:F" & i).Copy ActiveSheet.Range("l1")
10    ActiveSheet.Range("A1:F" & i).AutoFilter
11    Application.EnableEvents = True
12End Sub

1'工作簿保存时备份文件'
2Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)	'工作簿保存前触发事件'
3    Dim dateTime As String
4    dateTime = Format(Now(), "mmddhhmmss")  '获取当前时间
5    '保存工作簿时 新建一份副本
6    ThisWorkbook.SaveCopyAs Filename:="G:\code\vba\跟着王佩丰学VBA附件\VBA07\backup\" & dateTime & ".xlsx"
7End Sub

 1'制作密码验证表，输入对应的密码显示对应的工作表'
 2Private Sub Workbook_BeforeClose(Cancel As Boolean)	'工作簿关闭之前执行'
 3'隐藏除了登录以外的表'
 4Dim sht As Worksheet
 5For Each sht In Sheets
 6    If sht.Name <> "登录" Then
 7            sht.Visible = xlSheetVeryHidden '隐藏除登录外所有工作表
 8    End If
 9Next
10ActiveWorkbook.Save '保存活动工作簿
11End Sub
12
13Private Sub Workbook_Open() 	'工作簿打开时执行事件
14Dim i As String
15Dim sht As Worksheet
16i = InputBox("请输入密码")
17If "123" = i Then
18    For Each sht In Sheets
19        If InStr(sht.Name, "张三") <> 0 Then    '工作表名包含张三时
20            sht.Visible = xlSheetVisible    '显示工作表
21        End If
22    Next
23ElseIf "456" = i Then
24    For Each sht In Sheets
25        If InStr(sht.Name, "李四") <> 0 Then
26            sht.Visible = xlSheetVisible
27        End If
28    Next
29Else
30    MsgBox ("密码错误")
31    ActiveWorkbook.Close Savechanges:=True '不保存关闭工作簿
32End If
33End Sub

1'Countif  Vlookup这些函数在VBA里调用：Application.WorksheetFunction
2Instr() '函数可返回一个字符串在另一个字符串中首次出现的位置'
3Split() '用于将特定字符分开'
4On Error Resume Next '跳过错误语句'
5IsNumeric()	'返回 Boolean 值，返回变量是否为一个数值'
6Val()	'文本转化为数值'

 1Sub chaxun()
 2'On Error Resume Next  表示后面的程序出现"运行时错误"时，会继续运行，不中断
 3'VLookup（a,b,c,d） a：搜索的值  b：搜索的区域（多列） c：返回哪一列  d：是否精确匹配
 4
 5On Error Resume Next
 6Sheets(1).Range("d14:d22").ClearContents
 7d = Sheets(1).Range("d9")
 8For j = 2 To Sheets.Count
 9    Sheets(1).Range("d14") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 5, 0)
10    Sheets(1).Range("d16") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 6, 0)
11    Sheets(1).Range("d18") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 3, 0)
12    Sheets(1).Range("d20") = WorksheetFunction.VLookup(d, Sheets(j).Range("a:h"), 8, 0)
13    Sheets(1).Range("d22") = Sheets(j).Name
14    If Sheets(1).Range("d14") <> "" Then
15        Exit For
16    End If
17Next
18End Sub
19
20Sub tongji()
21'WorksheetFunction 通过该对象可以使用工作表函数
22'CountA(a) a为某一区域，计算非空单元格
23'CountIf(a,b) a为某一区域，b为条件，统计满足条件的单元格
24For i = 2 To Sheets.Count
25    k = k + WorksheetFunction.CountA(Sheets(i).Range("a:a")) - 1
26    m = m + WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "男")
27    w = w + WorksheetFunction.CountIf(Sheets(i).Range("f:f"), "女")
28Next
29Sheets(1).Range("d26") = k
30Sheets(1).Range("d27") = m
31Sheets(1).Range("d28") = w
32End Sub

 1Sub chaifenshuju()
 2
 3Dim sht As Worksheet
 4Dim k, i, j As Integer
 5Dim irow As Integer '这个说的是一共多少行
 6Dim l As Integer
 7Dim str As String '这里是第1处修改，加入一个变量，用于提取当前工作表的名字
 8str = ActiveSheet.Name '这里是第2处修改，取得当前要处理的表的名字
 9l = InputBox("请输入你要按哪列分")
10'删除无意义的表
11Application.DisplayAlerts = False
12If Sheets.Count > 1 Then
13    For Each sht1 In Sheets
14        If sht1.Name <> str Then '这里是第3处修改，不在用“数据”这个固定的名字了，而是用之前取到的名字
15            sht1.Delete
16        End If
17    Next
18End If
19Application.DisplayAlerts = True '这个地方上课的时候我没改成true，请大家注意一下
20irow = Sheets(str).Range("a65536").End(xlUp).Row '这里是第4处修改，不在用“sheet1”这个固定的表名字了，而是用之前取到的名字的表
21'拆分表
22For i = 2 To irow
23    k = 0
24    For Each sht In Sheets
25        If sht.Name = Sheets(str).Cells(i, l) Then '这里是第5处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
26            k = 1
27        End If
28    Next
29    If k = 0 Then
30        Sheets.Add after:=Sheets(Sheets.Count)
31        Sheets(Sheets.Count).Name = Sheets(str).Cells(i, l)   '这里是第6处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
32    End If
33Next
34'拷贝数据   注意：第7处修改。原有的Range("a1:f" & irow)已经改为Range("a1:z" & irow)  因为数据可能会列数很多，所以写成到z列，故意多写一些。￥￥￥￥￥￥￥￥￥￥￥￥￥
35For j = 2 To Sheets.Count
36    Sheets(str).Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name  '这里是第8处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
37    Sheets(str).Range("a1:z" & irow).Copy Sheets(j).Range("a1")  '这里是第9处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)￥￥￥￥￥￥￥￥￥￥￥
38Next
39Sheets(str).Range("a1:z" & irow).AutoFilter   '这里是第10处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
40Sheets(str).Select   '这里是第11处修改，跟第四个修改一样，把原来的sheet1替换成sheets(str)
41MsgBox "已处理完毕，牛逼不"
42End Sub

 1'遍历文件，并提取文件名，以下代码会将data下所有文件名写入A列'
 2Sub test()
 3    Dim name As String, i
 4    i = 1
 5    name = Dir("G:\code\vba\VBA10\data\*.*")
 6    Do
 7        Sheets("data").Range("a" & i) = name
 8        name = Dir  '当dir() 查询结果有多个文件时，dir则依次返回一个文件名，然后为空，再然后出错
 9        i = i + 1
10    Loop While name <> ""
11End Sub

 1Sub 合并多文件数据()
 2Application.ScreenUpdating = False
 3    Dim name As String, i, wb As Workbook, sht As Worksheet
 4    i = 1
 5    name = Dir("G:\code\vba\跟着王佩丰学VBA附件\VBA10\data2\*.*")
 6    Do
 7        Set wb = Workbooks.Open("G:\code\vba\跟着王佩丰学VBA附件\VBA10\data2\" & name)
 8        For Each sht In wb.Sheets
 9            sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '需指定哪个工作簿
10            'split 拆分字符串，返回一个数组
11            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).name = Split(wb.name, ".")(0) & sht.name
12        Next
13        name = Dir
14        wb.Close
15    Loop While name <> ""
16Application.ScreenUpdating = True
17End Sub

 1Sub chazhao()
 2	Dim rng As Range
 3    '如果找不到以下代码并不会报错，而是rng为空'
 4	Set rng = Range("d:d").Find(Range("l3"))
 5    '进行以下判断，这样就可以避免错误'
 6	If Not rng Is Nothing Then
 7         Range("m3") = rng.Offset(0, 3)
 8	End If
 9
10End Sub

 1Sub chaifenshuju()
 2Dim sht As Worksheet
 3Dim k, i, j As Integer
 4Dim irow As Integer '这个说的是一共多少行
 5Dim l As Integer
 6Dim sht0 As Worksheet
 7Set sht0 = ActiveSheet '需要拆分的表'
 8l = InputBox("请输入你要按哪列分")
 9
10'删除无意义的表
11Application.DisplayAlerts = False
12If Sheets.Count > 1 Then
13    For Each sht1 In Sheets
14        If sht1.Name <> sht0.Name Then
15            sht1.Delete
16        End If
17    Next
18End If
19Application.DisplayAlerts = True 
20
21irow = sht0.Range("a65536").End(xlUp).Row
22'拆分表
23For i = 2 To irow
24    k = 0
25    For Each sht In Sheets
26        If sht.Name = sht0.Cells(i, l) Then
27            k = 1
28        End If
29    Next
30
31    If k = 0 Then
32        Sheets.Add after:=Sheets(Sheets.Count)
33        Sheets(Sheets.Count).Name = sht0.Cells(i, l)
34    End If
35
36Next
37
38'拷贝数据
39For j = 2 To Sheets.Count
40    sht0.Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
41    sht0.Range("a1:z" & irow).Copy Sheets(j).Range("a1")
42Next
43
44sht0.Range("a1:z" & irow).AutoFilter
45sht0.Select
46MsgBox "已处理完毕，牛逼不"
47
48End Sub

 1Sub 总金额1()
 2
 3Dim i, xrow, j, k, str, ti
 4
 5ti = Timer
 6
 7xrow = Range("a1000000").End(xlUp).Row
 8ReDim arr(1 To 3, 1 To xrow)
 9str = Range("O5").Value
10For i = 2 To xrow
11    If Range("H" & i) = str Then
12        k = k + Range("J" & i)
13        j = j + Range("L" & i)
14    End If
15Next
16
17Range("P5") = k
18Range("Q5") = k
19
20MsgBox (Format(Timer - ti, "0.000000"))
21End Sub
22------------------------------------------------------------------------
23Sub 总金额2()
24
25Dim i, xrow, j, k, str, ti, arr()
26
27ti = Timer	'获取时间'
28
29xrow = Range("a1000000").End(xlUp).Row	
30ReDim arr(1 To 3, 1 To xrow)	'重新定义数组大小'
31str = Range("O5").Value
32arr = Range("H1:J" & xrow).Value	'连续的将单元格区域赋值给数组，注意：带sheets.range(区域)，后面必须跟上value'
33For i = 2 To xrow
34    If arr(i, 1) = str Then
35        k = k + arr(i, 3)
36        j = j + arr(i, 2)
37    End If
38Next
39
40Range("P5") = k
41
42MsgBox (Format(Timer - ti, "0.000000"))	'当前获取时间-程序开始时间，结果为程序运行时间'
43End Sub

 1Sub test()
 2Dim arr()
 3Dim j, i As Integer
 4
 5j = Range("a65536").End(xlUp).Row - 1
 6
 7ReDim arr(1 To j)	'重新定义数组大小'
 8
 9For i = 1 To j
10    arr(i) = Range("b" & i + 1) * Range("c" & i + 1)
11Next
12
13Range("h3") = Application.WorksheetFunction.Max(arr)	'调用工作表函数，数组可以看成一个单元格区域'
14'match，查看元素在区域内出现的位置'
15Range("h2") = Range("a" & Application.WorksheetFunction.Match(Range("h3"), arr, 0) + 1)
16
17MsgBox LBound(arr) '数组下限'
18
19End Sub

 1'问题：有许多汇款账单，但不知道谁是谁，现在知道收到的回款总额(124704)以及订单数(4)，求是哪些账单（每个账单金额唯一）'
 2'思路：尝试组合所有可能的组合，将金额加起来为124704的订单找出来'
 3Sub huikuan()
 4Dim arr(), i, j, k, xrow, t
 5t = Timer
 6xrow = Range("a65535").End(xlUp).Row - 1
 7arr = Range("A2:A" & xrow + 1)
 8For i = 1 To xrow
 9    For j = 1 To xrow
10        For k = 1 To xrow
11            For l = 1 To xrow
12                If arr(i, 1) + arr(j, 1) + arr(k, 1) + arr(l, 1) = Range("k3") Then '四笔订单和为收到汇款总额时
13                    Range("F3") = arr(i, 1)
14                    Range("G3") = arr(j, 1)
15                    Range("H3") = arr(k, 1)
16                    Range("I3") = arr(k, 1)
17                    GoTo 100    '程序跳到100处，这里结束所有循环
18                End If
19            Next
20        Next
21    Next
22Next
23100
24Range("L3") = Timer - t '程序执行时间
25End Sub

 1Sub adoTest()
 2Dim conn As New ADODB.Connection
 3Dim sql As String, arr()
 4
 5conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=G:\data\Edata.xlsx;extended properties=""excel 12.0;HDR=YES""" '打开excle文件，指定扩展属性以及表头
 6
 7'conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\data\Adata.accdb" '打开access数据库，只需要指定提供者和数据源
 8
 9'conn.Open "Provider=SQLOLEDB;DataSource=" & Path & ";Initial Catolog=" & strDataName 'Mysql数据库
10
11'conn.Open "Provider=MSDASQL;Driver={SQL Server};Server=" & Path & ";Database=" & strDataName 'MSSQL数据库
12
13'conn.Open "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password" 'Oracle数据库
14
15sql = "select * from [data$]" '从data工作表查询所有数据
16sql = "select * from [data$] where 性别=男" '条件查询
17sql = "select * from [data$] union all select * from [data2$]" '合并两个表数据
18
19Range("a2").CopyFromRecordset conn.Execute(sql) '将查询的记录写入A2单元格
20
21arr = Application.WorksheetFunction.Transpose(conn.Execute(sql).GetRows)    '将查询的记录赋值到数组
22
23'关闭链接
24conn.Close
25End Sub