小花鹿学习VBA记录

小花鹿

学习VBA的过程中，有很多思路、方法、单词、短语，当时写代码时还能记得，但时间长了想用时，一时就想不起来了，在网上查也比较麻烦，放在电脑里，一是查找也不方便，二是不安全，万一电脑坏了呢，所以就想把这些内容都放在这个帖子里，便于自己查找。
如果你有实质性的建议，欢迎跟帖，如果没有就算了，不欢迎“学习了”、“顶”、“谢谢楼主”之类的帖子，我不想盖楼。

目录：
难记的单词、短语、语句记录：
Randomize 初始化随机数生成器
按行读取文本文件：Line Input #1, s
整体读取文本文件：InputB(LOF(1), #1)
在A列只保留新输入的唯一一个数据：禁用事件
人民币大小写：自定义函数
自定义菜单和自定义工具栏实用操作技巧：
插入照片调整尺寸：
窗体、查询、照片：
进度条制作：
字典嵌套：
Union删除重复行：
contxt：内存数组连接自定义函数
B列记录A列修改次数：工作表事件
列出2013年的双休日：有关日期的知识
程序暂停10秒：Application.Wait (Now + TimeValue("0:00:10"))
列出ThisWorkbook.Path及子文件夹中的文件名：FSO及递归应用，34楼可选择文件类型和文件夹
递归简单模型：
VBA FSO对象模型详解
文本文件转xls：



补充内容 (2013-4-19 15:08):
Format函数

补充内容 (2017-5-17 10:49):
谢谢版主的技术分，我的第1个技术分就是你给的，给了我很大的鼓励。

小花鹿

难记的单词、短语、语句记录：
Set d = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
ar = Sheet3.UsedRange
Application.EnableEvents = False
With Sheet2
    .Cells(r - 8, 5).Select
    .Pictures.Insert(p & pic).Select  '在活动单元格中插入照片并选中
    Selection.Width = .Cells(r - 8, 5).MergeArea.Width  '包含Cells的合并单元格的宽度
    Selection.Height = .Cells(r - 8, 5).MergeArea.Height
End With
Open thispath & mytxt For Input As #1
Line Input #1, s
tm = Split(StrConv(InputB(LOF(1), #1), vbUnicode), vbCrLf)
n = Int(Rnd() * (r - i + 1)) + i
Application.Wait (Now + TimeValue("0:00:10"))  '程序暂停10秒
Set fso = CreateObject("scripting.filesystemobject")  '引用文件系统对象
Set Folder = fso.getfolder(pth)  '获得文件夹对象
Set SubFolder = Folder.subfolders  '获得子文件夹对象
For Each fd In SubFolder  '遍历文件夹
    For Each f In fd.Files  '遍历文件对象（fd.Files）中的文件
pth=Fso.getfolder(ActiveWorkbook.Path).parentfolder  '获得ActiveWorkbook.Path的父目录（parentfolder）
fso.getextensionname ("c:\abc\test.txt")  '最后部件扩展名：txt
fso.getbasename ("c:\abc\test.txt")  '最后部件基本名：test
DateValue(Format("2008-3-12", "yyyy-mm-") & "01") - 1  '上月月底的日期









补充内容 (2014-10-7 12:38):
If Application.Intersect(Target, Range("a1:a10")) Is Nothing Then Exit Sub


补充内容 (2014-10-11 14:10):
ActiveSheet.UsedRange.Find("*", ActiveSheet.UsedRange.Cells(1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row

补充内容 (2016-9-28 22:56):
有数据的行列号：
sheet1.Cells.Find("*",,,,xlbyrows,xlPrevious).row
sheet1.Cells.Find("*",,,,xlbycolumns,xlPrevious).column

补充内容 (2016-11-3 09:08):
Sub 尾行号()
    pg = ExecuteExcel4Macro("Get.Document(50)")    '总页数
    For i = 1 To pg - 1  '最后一页不检测,尾页不满一页会报错
        p = Application.ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64)," & i & ")") - 1    '每页行号
    Next
End Sub

补充内容 (2016-11-16 12:11):
endrow = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
endCol = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column

补充内容 (2018-2-11 19:17):
Sub 正则()
Dim reg, s, r&, i&, ss, tm, x
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "[\(（]([A-Z]+)[\)）]"
reg.Global = True
r = [a65536].End(3).Row
For i = 1 To r
    x = ""
    s = Cells(i, "a")
    Set ss = reg.Execute(s)
    For Each tm In ss
        x = x & tm.submatches(0)
    Next tm
    Cells(i, "a") = s & "参考答案" & x
Next i
End Sub

补充内容 (2018-6-30 22:22):
Private Sub TextBox5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim r&
If KeyCode = 13 Then
    KeyCode = 0
    r = [a65536].End(3).Row + 1
    Cells(r, 1) = TextBox5
    TextBox5.SelStart = 0
    TextBox5.SelLength = Len(UserForm1.TextBox5.Text)
End If
End Sub

小花鹿

Randomize 初始化随机数生成器

Randomize：初始化随机数生成器。
语法
Randomize [number]
可选的 number 参数是 Variant 或任何有效的数值表达式。
说明
Randomize 用 number 将 Rnd 函数的随机数生成器初始化，该随机数生成器给 number 一个新的种子值。如果省略 number，则用系统计时器返回的值作为新的种子值。
如果没有使用 Randomize，则（无参数的）Rnd 函数使用第一次调用 Rnd 函数的种子值。
注意 若想得到重复的随机数序列，在使用具有数值参数的 Randomize 之前直接调用具有负参数值的 Rnd。使用具有同样 number 值的 Randomize 是不会得到重复的随机数序列的。

下列代码如果没有Randomize， 则每次打开xls并运行程序时会产生相同的随机序列，否则会产生不同的随机序列，因为种子值不同了：
Sub test()
Dim i&, c&
Randomize
With Sheet1
    c = .[iv1].End(xlToLeft).Column + 1
    For i = 1 To 10
        .Cells(i, c) = Rnd()
    Next i
End With
End Sub
  


补充内容 (2018-2-11 19:20):
Sub 正则()
Dim reg, s, r&, i&, ss, tm, x
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "[\(（]([A-Z]+)[\)）]"
reg.Global = True
r = [a65536].End(3).Row
For i = 1 To r
    x = ""
    s = Cells(i, "a")
    Set ss = reg.Execute(s)
    For Each tm In ss
        x = x & tm.submatches(0)
    Next tm
    Cells(i, "a") = s & "参考答案" & x
Next i
End Sub

小花鹿

按行读取文本文件：
Option Explicit
Sub test()
Dim thispath As String, mytxt As String, n&, s, tm, br(), i&
thispath = ThisWorkbook.Path & "\"
mytxt = Dir(thispath & "*.txt")
Open thispath & mytxt For Input As #1
Do Until EOF(1)
    n = n + 1
    Line Input #1, s
    tm = Split(s, ",")
    If n = 1 Then ReDim br(1 To 65536, UBound(tm))
    For i = 1 To UBound(tm)
        br(n, i) = tm(i)
    Next i
    br(n, 0) = "'" & tm(0)
Loop
Close #1
Sheet2.[a1].Resize(n, i) = br
End Sub

原始数据（txt）：
代码,fails,STEP,DEVICE,ACT,UT,LOW,HIGH,TestMSR,A,B
123456789020,fail,159,PR856-T,5,o,0.05,8,99999,351,359
123456789012,fail,985,C869-T,34.05,PF,,44.265,54.3096,1,68
123456789022,fail,1404,,0.13,uF,0.065,0.195,0.055,,1
123456789012,fail,1423,C810-B,0.1,uF,0.065,0.14,,1675,
123456789012,fail,1607,C529-T,1,,0.6,1.3,0.5866,742,1
123456789025,fail,1645,C1091-B,1,uF,0.65,,0.6016,1259,1258
123456789012,fail,,,1,uF,,1.7,,343,1
123456789012,fail,1827,PC526-T,38,uF,26.6,49.4,25.5999,1,316

小花鹿

整体读取文本文件：
Option Explicit
Sub test()
Dim thispath As String, mytxt As String, s, tm, br(), i&, j&
thispath = ThisWorkbook.Path & "\"
mytxt = Dir(thispath & "*.txt")
Open thispath & mytxt For Input As #1
tm = Split(StrConv(InputB(LOF(1), #1), vbUnicode), vbCrLf)
Close #1
For i = 0 To UBound(tm)
    s = Split(tm(i), ",")
    If i = 0 Then ReDim br(UBound(tm), UBound(s))
    For j = 1 To UBound(s)
        br(i, j) = s(j)
    Next j
    br(i, 0) = "'" & s(0)
Next i
Sheet3.[a1].Resize(i, j) = br
End Sub

原始数据（txt）：
代码,fails,STEP,DEVICE,ACT,UT,LOW,HIGH,TestMSR,A,B
123456789020,fail,159,PR856-T,5,o,0.05,8,99999,351,359
123456789012,fail,985,C869-T,34.05,PF,,44.265,54.3096,1,68
123456789022,fail,1404,,0.13,uF,0.065,0.195,0.055,,1
123456789012,fail,1423,C810-B,0.1,uF,0.065,0.14,,1675,
123456789012,fail,1607,C529-T,1,,0.6,1.3,0.5866,742,1
123456789025,fail,1645,C1091-B,1,uF,0.65,,0.6016,1259,1258
123456789012,fail,,,1,uF,,1.7,,343,1
123456789012,fail,1827,PC526-T,38,uF,26.6,49.4,25.5999,1,316

不想占楼层，在这里回复6楼：原理很明白，只是写代码时还得想一会，特别是这句 n = Int(Rnd() * (r - i + 1)) + i


补充内容 (2016-10-30 11:02):
Sub test1()
Dim thispath As String, mytxt As String, s, tm, br(), i&, j&, ad
    Set ad = CreateObject("adodb.stream")
    With ad
        .Charset = "utf-8"
        .Type = 2
        .Open
        .LoadFromFile ThisWorkbook.Path & "\@Template.htm"
         tm = .ReadText
        .Close
    End With
tm = Split(tm, vbCrLf)
For i = 0 To UBound(tm)
    Cells(i + 1, 1) = tm(i)
Next i
End Sub

补充内容 (2016-12-8 11:33):
Sub getdata()
Dim rst As Object, StrConn As String, arr As Variant
Set rst = VBA.CreateObject("ADODB.Recordset")
StrConn = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='" _
+ "text;hdr=yes';data source=" & ThisWorkbook.Path & "\"
rst.Open "d1.txt", StrConn, 1, 3
rst.Move 1
arr = rst.GetRows()
rst.Close
MsgBox UBound(arr)
MsgBox UBound(arr, 2)
[a1:g1] = arr
Set rst = Nothing
End Sub

香川群子

呵呵，【数组洗牌法】得到随机乱序的代码已经记得很熟了么……

小花鹿

在A列只保留新输入的唯一一个数据：
Private Sub Worksheet_Change(ByVal Target As Range)
c = 1
If Target.Column <> c Then Exit Sub
tm = Target.Value
Application.EnableEvents = False
Columns(c).ClearContents
Target = tm
Application.EnableEvents = True
End Sub

小花鹿

代码来自本站，放在这里是为了查找方便，谢谢原作者。

人民币大小写：
Function 人民币大写(M)
y = Int(Round(100 * Abs(M)) / 100)
j = Round(100 * Abs(M) + 0.00001) - y * 100
f = Round((j / 10 - Int(j / 10)) * 10)
A = IIf(y < 1, "", Application.Text(y, "[DBNum2]") & "元")
b = IIf(j > 9.4, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 0.4, "零", "")))
c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分")
人民币大写 = IIf(Abs(M) < 0.005, "", IIf(M < 0, "负" & A & b & c, A & b & c))
End Function

Function DxToN(ss)
    For i% = 1 To 9
        ss = Replace(ss, Mid("壹贰叁肆伍陆柒捌玖", i, 1), i)
        ss = Replace(ss, Mid("一二三四五六七八九", i, 1), i)
    Next
    For i% = Len(ss) To 1 Step -1
        s$ = Mid$(ss, i, 1)
        x% = InStr("分角圆拾佰仟万拾佰仟亿拾佰仟兆", s)
        If x = 0 Then x% = InStr("分毛元十百千萬十百千億十百千兆", s)
        If x Then j% = IIf(j% < x, x, ((j - 3) \ 4) * 4 + x)
        If Val(s) Then M# = M# + (s & String(j - 1, "0")) / 100
    Next
    DxToN = Round(M, 2)
    If InStr(ss, "-") Or InStr(ss, "负") Then DxToN = -DxToN
End Function

小花鹿

附件来自本站，放在这里是为了查找方便，谢谢原作者：

自定义菜单和自定义工具栏实用操作技巧：


补充内容 (2016-12-15 19:03):
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/><Relationship Id="customUIRelID" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/><Relationship Id="rId2" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/><Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="xl/workbook.xml"/></Relationships>

小花鹿

附件来自本站，放在这里是为了查找方便。

插入照片调整尺寸：
Sub test()
Dim arr, i&, r&, p$, pic$
arr = Sheet1.Range("a1").CurrentRegion
p = ThisWorkbook.Path & "\照片\"
For i = 2 To UBound(arr)
    With Sheet2
        r = .[a65536].End(3).Row
        .Rows((i - 2) * 10 + 1 & ":" & r).Copy .Rows(r + 2)
        .Cells(r - 8, 2) = arr(i, 1)
        .Cells(r - 7, 2) = arr(i, 2)
        .Cells(r - 7, 4) = arr(i, 3)
        .Cells(r - 6, 2) = arr(i, 4)
        .Cells(r - 5, 3) = arr(i, 5)
        .Cells(r - 4, 6) = arr(i, 6)
        .Cells(r - 3, 3) = "'" & arr(i, 7)
        .Cells(r - 2, 3) = "'" & arr(i, 8)
        .Cells(r - 1, 3) = arr(i, 9)
        .Cells(r, 3) = arr(i, 10)
        pic = Dir(p & arr(i, 1) & ".*")
        If pic <> "" Then
            .Cells(r - 8, 5).Select
            .Pictures.Insert(p & pic).Select
            Selection.Width = .Cells(r - 8, 5).MergeArea.Width
            Selection.Height = .Cells(r - 8, 5).MergeArea.Height
        End If
    End With
Next i
ActiveCell.Select
End Sub


补充内容 (2016-7-10 10:37):
.Pictures.Insert(p & pic).Select
            Selection.Top = .Cells(r - 8, 5).Top
            Selection.Left = .Cells(r - 8, 5).Left
            Selection.Width = .Cells(r - 8, 5).MergeArea.Width
            Selection.Height = .Cells(r - 8, 5).MergeArea.Height