一些vba知识20200909

'怎么按.弹出提示：dim a as ？？后a.即可。
'如想提示comment对象的方法和属性，Dim t As Comment后输入t.即可

Sub s()
	[a1] = "=b1 + 16"                           '=B1+16
	[a2] = Evaluate("=b1 + 16")                 '17,显示公式计算的结果
	[a3] = "=b1" & "&""me""" & "&16"            '=B1&"me"&16
	[a4].FormulaArray = "=sum(b1:b2*c1:c2)"     '={=SUM(B1:B2*C1:C2)}
End Sub

Sub s()
	For i = 1 To 11
	    If i = 5 Then Stop						'运行到这里会进入debug模式
	Next i
End Sub

Sub s()							'a1的内容是"=3-1",并把格式设成百分比
	'.text  是设置了格式后显示的内容，  而.value 是单元格内实际的值
    Debug.Print [a1].Text       '200.00%
    Debug.Print [a1].Value      '2
    Debug.Print [a1].Formula    '=3-1
End Sub

Sub s()							
    Dim t As Comment
    Set t = [a1].Comment
    t1 = t.Text					'获取注释的文本内容
    t.Delete					'删除注释
End Sub

Sub s()
	'第一个参数是行是否绝对地址，第二是列，默认全部绝对地址
    t1 = [a1].Address(0, 1)          '$A1
    t2 = [a1].Address(1, 0)          'A$1
    t3 = [a1].Address(1, 1)          '$A$1
    t4 = [a1].Address(0, 0)          'A1
    t5 = [a1].Address                '$A$1
End Sub

Sub s()						'单元格的位置信息
    t1 = [b2].Top
    t2 = [b2].Left
    t3 = [b2].Width
    t4 = [b2].Height
End Sub

't1是单元格的parent，工作表；t2是工作表的parent，工作簿
Sub s()
    Set t1 = [b2].Parent
    tn1 = t1.Name
    Set t2 = t1.Parent
    tn2 = t2.Name
End Sub

Sub s()
    '如果区域中所有单元格均包含公式，则该属性值为 True；
    '如果所有单元格均不包含公式，则该属性值为 False；
    '其他情况下为 null。 只读 Variant 类型。
    t1 = [a1].HasFormula
    t2 = [a2].HasFormula
    t3 = Range("a1:a2").HasFormula
    '获取一个区域里Hyperlinks超链接的格式
    t4 = Range("a1:c4").Hyperlinks.Count
End Sub

'type(单元格)=range，type(空单元格.value)=empty，可以用来判断单元格是否非空
Sub s()
    'a1是数字，a3是字符串asd，a3是字符串123('123)，a11是空单元格
    'a5是=1/0(显示#DIV/0!)，
    t1 = IsEmpty([a1])                                              'false
    t2 = IsEmpty([a11])                                             'true，可以用来判断单元格是否非空
    
    'vba的函数忘记名字时，vba.可以得到提示
    'IsNumeric判断是不是数字，但空单元格也返回true，所以需要 And Not IsEmpty([a11])
    t3 = VBA.IsNumeric([a1])                                        'true
    t4 = IsNumeric([a1])                                            'true
    t5 = VBA.IsNumeric([a11])                                       'true
    t6 = VBA.IsNumeric([a11]) And Not IsEmpty([a11])                'false

    t7 = Application.WorksheetFunction.IsNumber([a1])               'true
    t8 = Application.WorksheetFunction.IsNumber([a11])              'false
    
    s1 = Application.WorksheetFunction.IsText([a1])                 'false
    s2 = Application.WorksheetFunction.IsText([a11])                'false
    s3 = Application.WorksheetFunction.IsText([a3])                 'true
    a3type = VBA.TypeName([a3].Value)                               'string
    a4type = TypeName([a4].Value)                                   'string
    
    s5 = VBA.IsError([a5])                                          'true
    a5type = TypeName([a5].Value)                                   'error
    
    '判断单个字符是不是小写字母，注意a<a啊<z
    s6 = [a7] >= "a" And [a7] <= "z"

	'isdate方法判断标准不太明白，需要用时再百度
End Sub

Sub s()
   Dim rg As Range
   Set rg = [a1]
   For i = 2 To 4
    Set rg = Union(rg, Range("a" & i))
    rg.Select
   Next i
   rg.Merge							'union之后一起合并单元格效率更高
End Sub

Sub s()
   'a2:b4
   'Dim t As Range
   Set t = [b3].MergeArea    		'[b3]所属的MergeArea，是range对象
   t1 = t.Row              			'2，MergeArea区域第一个单元格的row
   t2 = t.Column           			'1，MergeArea区域第一个单元格的column
   t3 = t.Count            			'6
   t4 = t.Address           		'"$A$2:$B$4"
End Sub

Sub s()
	'合并单元格时可能弹窗提示，不让提示
	Application.DisplayAlerts = False
	'MergeCells似乎和HasFormula一样，区域里不包含合并单元格返回false，
	'区域里全部是合并单元格返回true，否则(有合并单元格也有非合并的单元格)返回null
    Range("a2:b3").MergeCells = True
    t1 = Range("a1:b1").MergeCells		'false
    t2 = Range("a1:b3").MergeCells		'null
    t3 = Range("b2:b3").MergeCells		'true
    
	'两种合并单元格方法
    Range("b2:b5").MergeCells = True
    'Range("b2:b5").Merge	
    			
    '两种取消合并单元格方法，只要把mergearea里任何一个单元格取消合并，整个区域都会取消
    Range("b2:b2").MergeCells = False
    'Range("b2:b2").UnMerge		
    Application.DisplayAlerts = True		
End Sub

Sub s()
    'chr(13)是回车符，enter
    'chr(10)是换行符，LF, Line Feed, 换行，进纸一行
    [a1] = "a" & Chr(10) & "b"          'a换行b
    [a2] = "a" & Chr(13) & "b"          'ab
End Sub

'选择某区域，选择性粘贴数值+转置的录制宏
Sub s()
    Selection.Copy
    Range("a1").PasteSpecial Paste:=xlPasteValues,operation:=xlPasteSpecialOperationNone, Transpose:=True
End Sub

'把a1:a7的值加到b1:b7上，也可以写operation:=xlAdd,还可以对被选择的区域进行粘贴
Sub s()
    Range("a1:a7").Copy
    Range("b1").PasteSpecial operation:=xlPasteSpecialOperationAdd
	'Range("a1").PasteSpecial operation:=xlAdd
End Sub

Sub s()			'一个区域里，只要某个单元格为空，则删除该行
    Range("a1:b7").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

'也可以用EntireColumn删除列，还可以用ClearContents清除内容
'如果该区域没有空单元格，SpecialCells(xlCellTypeBlanks)会返回nothing，继续执行会报错，需要处理
'删除行时，如果第一列删除1和2行，第二列删除2和3行，会报错不能在重叠区域使用此命令。
'debug可以发现此时选择了4行(1,2,2,3)，可以考虑遍历t进行union再删除
Sub s()
    Dim t As Range
    Set t = Range("a1:d7").SpecialCells(xlCellTypeBlanks)       'nothing
    t.Select
    Set t = t.EntireRow
    'Set t = t.EntireColumn
    t.Select
    't.ClearContents
    t.Delete
End Sub

Sub s()			'fillup和fillleft失败了，resize不能输入负数。可以考虑转换成down和right
    Set rg = [c4]
    [c4] = "=row()*2"
    rg.Resize(9, 1).FillDown
    rg.Resize(1, 9).FillRight
    Set r = rg.Offset(-2, 1)
    r.Select
    r.Resize(3, 1).Select
    rg.FillUp
End Sub

Sub s1()					'多列填充公式
    Set rg = [c4:e4]
    rg(1) = "=row()"
    rg(2) = "=row()*2"
    rg(3) = "=row()*3"
    rg.Resize(9, 3).FillDown
End Sub

'循环查找非空的单元格，可以发现range的第2个单元格开始找，跳过了b4，最后再找b4
'LookIn默认是xlFormulas，同时检索value和公式
'如果之前的检索设置LookIn:=xlValues，这次检索不设置(用默认的)，会沿用上次检索的设置(LookIn:=xlValues)
'lookat:=xlPart, LookIn:=xlFormulas可以检索到部分公式的内容，如what:=r时可以检索到row函数
Sub s1()
    Dim r As Range
    Set r = Range("b4:c10")
    searchword = "*"
    Set x2 = r.Find(searchword, lookat:=xlPart, LookIn:=xlFormulas)
    If Not x2 Is Nothing Then x3 = x2.Address
    Do While True
        If x2 Is Nothing Then Exit Do
        x2r = x2.Row
        x2c = x2.Column
        MsgBox x2r & ":" & x2c
        Set x2 = r.Find(searchword, after:=x2)
        If x3 = x2.Address Then Exit Do
    Loop
End Sub

'返回行数最大的非空单元格，searchorder:=xlColumns查找列数最大的非空单元格
Sub s1()
    Set d = ActiveSheet.Cells.Find("*", searchdirection:=xlPrevious, searchorder:=xlRows)
    MsgBox d.Row
End Sub

'Target = Target + 1会不停的触发Worksheet_Change，修改EnableEvents可以避免不停触发
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    MsgBox Target.Value & ":" & Target.Address
    Target = Target + 1
    Application.EnableEvents = True
End Sub

Sub s()
    a = Array(1, 9, 7, -100, 5, 6, "A", "c", "a")
    a(3) = Empty
    a1 = Application.Max(a)             '9
    a2 = Application.Min(a)             '1
    a3 = Application.Large(a, 2)        '7，数组第2大的值
    a4 = Application.Small(a, 2)        '5，数组第2小的值
    a5 = Application.Sum(a)             '28，数组求和
    a6 = Application.Count(a)           '5，数组里数字个数
    a7 = Application.CountA(a)          '8，数组里已填充内容的个数
    a8 = Application.Match("a", a, 0)   '7，在数组里查找，不排序，不区分大小写，从1开始
    a9 = Application.Match("C", a, 0)   '8
    a0 = Application.Match("z", a, 0)   'error
End Sub

Match_type行为

Match_type=1 或省略
MATCH 查找小于或等于 lookup_value 的最大值。 lookup_array 参数中的值必须以升序排序，例如：…-2,
-1, 0, 1, 2, …, A-Z, FALSE, TRUE。
Match_type=0
MATCH 查找完全等于 lookup_value 的第一个值。 lookup_array 参数中的值可按任何顺序排列。
Match_type=-1
MATCH 查找大于或等于 lookup_value 的最小值。 lookup_array 参数中的值必须按降序排列，例如：TRUE,
FALSE, Z-A, …2, 1, 0, -1, -2, … 等等。

Sub s11()
    s = "a-b-a-d"
    a = VBA.Split(s, "-")
    s1 = VBA.Join(a, ",")
    
    '参数3=true时根据条件筛选出新数组，false时取反，默认true
    a1 = VBA.Filter(a, "a")             'a,a
    a2 = VBA.Filter(a, "a", False)      'b,d
    
    'index可以获取二维数组的某一行/列，得到新数组
    Dim b(2, 3)
    For i = LBound(b) To UBound(b)
        For j = LBound(b, 2) To UBound(b, 2)
            b(i, j) = i * 10 + j
        Next j
    Next i
    Cells(1, 1).Resize(UBound(b) - LBound(b) + 1, UBound(b, 2) - LBound(b, 2) + 1) = b
    b1 = Application.Index(b, , 1)             '第一列(索引=0的列),(1 to 3,1 to 1)
    b2 = Application.Index(b, 1)               '第一行(索引=0的行),(1 to 4)

    c = Application.VLookup(10, b, 4, 0)        '13，返回第一列是10的行的第四个值
    
    'application.worksheetfunction.countif的参数1是range，用数组一直报错，sumif也是
End Sub

'根据条件设置格式的3种方法：
'比如第一列的某行的值满足某条件，就给该行的a,b列设置颜色
Sub s1()			'方法1，根据条件拼接范围的字符串，最后设置格式。注意字符串长度不能超过255
    s = "a1:b3,a6:b6"
    Range(s).Interior.Color = RGB(222, 222, 222)
End Sub

Sub s2()			'方法2，字符串只拼接行数，取交集设置格式
    s = "1:3,6:6"           '注意这里不能写1:3,6
    Application.Intersect(Range("a:b"), Range(s)).Interior.Color = RGB(222, 222, 222)
End Sub

'方法3，如果只对数据所在的单元格设置格式，可以用条件格式设置。具体代码可录制宏

Function a(ParamArray n())			'用ParamArray设置不定参数，对sub也适用
    For Each i In n
        MsgBox i
    Next i
    aa = n
End Function

Sub b()
    Call a(2, [a1], "g", True)
End Sub

'worksheetfunction的choose方法：参数1是索引，之后的不定参数是选取范围，返回此范围里第索引(从1开始)个值
'参数是小数时，向下取整。所以代码返回A1:B1，再求和
=SUM(CHOOSE(1.8,A1:B1,A2:B2,A3:B3))

Sub s11()
    Dim x() As Byte
    x = StrConv("ABcd", vbFromUnicode)      '65,66,99,100
    
    y = Asc("A")                            '65
    a = Chr(65)                             'A
    b = String(4, "a")                      'aaaa
    
    s = "  a b  "
    s1 = Trim(s)                            '"a b"
    s2 = LTrim(s)                           '"a b  "
    s3 = RTrim(s)                           '"  a b"    
    
 	v = Val("1+2a")							'返回1，val可以提取字符串前面的数字
End Sub

Sub s11()
    Dim r As Range
    Set r = Application.InputBox("", Type:=8)               '必须+application
    MsgBox r.Parent.Name & ":" & r.Address                  'Sheet1:$A$1:$B$2
    x1 = Application.InputBox("", Type:=1)                  '只能输入数字
    x2 = Application.InputBox("", Type:=2)                  '文本，输入数字被转成文本数字
    x4 = Application.InputBox("", Type:=4)                  '布尔值，输入文本会被转成布尔值
    x64 = Application.InputBox("", Type:=64)                '数组，如输入{"a",3}
End Sub

通常，用户自定义函数后，在“粘贴函数”对话框中将会出现在“用户定义”类别中。如果希望自定义函数出现在其它的类别中，必须编写和执行VBA代码为自定
义函数指定类别。如运行Application.MacroOptions
Macro:=”SumPro”,Category:=4语句后，将自定义的SumPro函数指定给“统计函数”类别。

Sub 类型判断()
    '判断是不是数字，空单元格返回false
    t1 = Application.WorksheetFunction.IsNumber([a33])
    
    Dim arr(), ar
    t2 = VBA.IsArray(arr)                   'true
    t3 = VBA.IsArray(ar)                    'false
    
    '是不是单个字母，也可以用Asc("A")判断
    t4 = "A" Like "[A-Za-z]"                'true
    t5 = "[A-Za-z]" Like "A"                'false，注意顺序
End Sub

Sub uu()
	d1 = Date                               '#2020/9/25#
	d2 = Time                               '#11:27:00#
	d = Now()                               '#2020/9/25 11:27:00#
	a1 = Format(d, "mmmm-dddd-yyyy")        'September-Friday-2020
	a2 = VBA.DateSerial(2020, 11, 22)       '#2020/11/22#
	a3 = VBA.TimeSerial(11, 12, 13)         '#11:12:13#
	a4 = Year(d)
	a5 = Month(d)
	a6 = Day(d)
	a7 = Hour(d)
	a8 = Minute(d)
	a9 = Second(d)
End Sub

Sub uu()
	d1 = #11/11/2020#               '注意不要双引号
	d2 = #12/22/2022#
	a1 = DateDiff("m", d1, d2)      '12*2+1=25
	d3 = DateAdd("m", -25, d2)      '#2020/11/22#
	d4 = d1 - d2                    '-771，11+30+365*2=771，2020多出的1天在2月，不用加进去
End Sub

Sub uu()				'当前时间+11秒，方法3可以输入负数
    d1 = Now + #12:00:11 AM#
    d2 = Now + TimeValue("00:00:11")
    d3 = DateAdd("s", 11, Now)
End Sub

'插入图片，录制宏后稍加修改
Sub Macro1()				'直接插入图片
    Range("B2").Select
    ActiveSheet.Shapes.AddPicture Filename:="D:\壁纸\pic\Konachan.com - 266929 sample.jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=-1, Top:=-1, Width:=-1, Height:=-1
End Sub

'先插入矩形，把图片设为矩形的背景图片，这样可以控制图片的大小（直接设置图片大小由于图片的比例问题失败）
'矩形的边框不知道怎么去除，这里用s.Line.Visible = msoFalse设为不可见
'OnAction 可以设置点击图片调用的方法
Sub a()						
    Dim s As Shape
    Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=61.200001, Top:=34.200001, Width:=297, Height:=139.199997)
    's.Select
    s.Line.Visible = msoFalse
    s.OnAction = "'1.xls'!asd"
    s.Fill.Transparency = 0
    With s.Fill
        .UserPicture PictureFile:="D:\壁纸\pic\Konachan.com - 266929 sample.jpg"
        .Transparency = 0
    End With
End Sub

Sub uu()
    Dim s As Shape
    For Each s In Sheets(1).Shapes
        a1 = s.TopLeftCell.Address
        a2 = s.BottomRightCell.Address
        a3 = s.Visible
        a4 = s.OnAction
        s.Visible = True
        s.Left = [b3].Left		'移动图片，使左上角与[b3]单元格左上角对齐
        s.Top = [b3].Top
        t=s.type				'不同类型的图形type不同，详情百度
    Next s
End Sub

Sub b()							'批量删除和创建多选框
    Set sh = ActiveSheet
    For Each s In sh.CheckBoxes
        s.Delete
    Next s
    For Each rg In Range("a1:a5")
        Set c = sh.CheckBoxes.Add(rg.Left, rg.Top, rg.Width, rg.Height)
        c.Text = rg.Address(0, 0)				'A1,A2,...,A5
    Next
End Sub

Sub b()								'批量隐藏/显示sheet
    Dim a(2)
    a(0) = 1
    a(1) = 2
    Sheets(a).Visible = True
End Sub

'类模块rr
Option Explicit
Dim a, b
Property Let aa(a1)
    a = a1
End Property

Property Let bb(b1)
    b = b1
End Property
Property Get ss()
    ss = a * b
End Property

Property Set red(rg As Range)
    rg.Interior.Color = RGB(255, 0, 0)
End Property

'普通模块
Sub u()
    Dim p As New pp
    p.aa = 3
    p.bb = 2
    x = p.ss				'6
    Set p.red = [a1]		'a1变红
End Sub