range相关

range.row:返回range左上角单元格的行号
range.column:返回列号
range.address：返回各个对角顶点的绝对引用地址

Sub rangedemo()
Dim r As Range
Set r = Range("B3:D9")
r.Select
'让上面的单元格被选中
MsgBox r.Row & "行" & r.Column & "列"
'输出range范围

End Sub

或者写

MsgBox r.Address

返回绝对引用的位置

range.rows(n)用来返回所选range第一行的位置

在这里插入图片描述

Sub RowsDemo()
Dim a As Range, rw As Range

Set a = Range("c4:e12")

a.Select

Set rw = a.Rows(1)

MsgBox "第一行的范围是:" & rw.Address

End Sub

判断一共有多少行

Sub RowsDemo()
Dim a As Range, rw As Range

Set a = Range("c4:e12")

a.Select

MsgBox "一共有" & a.Rows.count & "行"

End Sub

找最后一行结合cells

Sub FindLastRow()
Dim i As Long, lastRow As Long
i = 3

Do While Trim(Cells(i, 2)) <> "" And ActiveSheet.Cells.Rows.count
'本工作表.全部范围.所有行.总数，防止出现占满整个表
'寻找时产生了溢出
i = i + 1
Loop
If Cells(i, 2) = "" Then
lastRow = i - 1
Else: lastRow = i
End If
MsgBox "最后一条数据在第" & lastRow & "行"
 
End Sub

针对不规则的range，利用usedrange来找范围

Sub usedrangedemo()
    Dim r As Range
    Set r = ActiveSheet.UsedRange
    '找用过的单元格
    '格式，字体都算用过
    r.Select
    MsgBox r.Address
End Sub

找最后一行或者列

Sub usedrangedemo()
    Dim r As Range, i As Long
    Set r = ActiveSheet.UsedRange
    '找用过的单元格
    '格式，字体都算用过
    i = r.Row + r.Rows.count - 1
    '用来找最后一行
    MsgBox "最后一行是" & i
End Sub

二维数组

如果采用一行行读取的方式，效率低下
在这里插入图片描述

Sub 不用二维数组()
Dim i As Long, j As Long
Dim t
t = Timer
For i = 1 To 50000
    For j = 1 To 20
        Cells(i, j) = i + j
    Next j
Next i

MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

采用二维数组来读取
在这里插入图片描述

Sub 用二维数组()
Dim s(), r As Range, i As Long, j As Long
Dim t
t = Timer
Set r = ActiveSheet.UsedRange
'设置r的范围
s = r.Value
's= range("A1:T50000")

For i = 1 To r.Rows.count
' for i=1 to range("A1:T50000).rows.count
'如果需要确定，可以用count
    For j = 1 To r.Columns.count
    'For j=1 to range("A1:T50000).Columns.count
        s(i, j) = s(i, j) * 2
    Next j
Next i

r.Value = s
MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

写法二

建立二维数组

Sub 建立二维数组()
Dim word As String, s()
's必须是动态数组，且不能指明类型
s = Range("b3:e5")
word = s(1, 2)
MsgBox word
End Sub

写入二维数组

Sub writerange()
Dim s(1, 2) As Integer
'写入的时候可以给类型
s(0, 0) = 1: s(0, 1) = 3: s(0, 2) = 2
s(1, 0) = 5: s(1, 1) = 5: s(1, 2) = 3
'下标从0开始
Range("b2:d3") = s
End Sub

转置二维数组

Sub 转置()
Dim s(3) As Integer, i As Integer
s(0) = 1: s(1) = 2: s(2) = 3: s(3) = 4
Range("c2:c5") = Application.Transpose(s)
'转置

End Sub

确定上下界

Sub 定上下界()
Dim s(2 To 5, 3 To 7)
Cells(1, 1) = UBound(s, 1)
'行向量的上界
Cells(1, 2) = LBound(s, 2)
'列向量的下界
End Sub

扫描每个表内红色字体的数字求和

Option Explicit
Sub 扫描()

Dim i As Long, j As Long, s As Long
Dim r As Range, w As Worksheet
Dim r1 As Range
For Each w In Worksheets

s = 0

Set r = w.UsedRange

    For Each r1 In r
    '把所选表中的每个cell看成一个小range
    '从左到右从上到下进行扫描
    '化二维为一维
    
    If r1.Font.Color = vbRed Then
        s = s + r1.Value
    End If
    
    Next r1
    
    w.Cells(1, 1) = s
    '累加结果返回到工作簿A1
Next w
End Sub

还可以分模块完成，优化代码

Sub DEMO()
Dim w As Worksheet

For Each w In Worksheets
w.Cells(1, 1) = redcount(w.UsedRange)
Next w

End Sub

Function redcount(r As Range)
Dim s As Long, r1 As Range

For Each r1 In r
    If r1.Font.Color = vbRed Then
        s = s + r1.Value
    End If
Next r1

redcount = s
'把值返参
End Function

在这里插入图片描述
也可以直接当做公式来用

自定义公式的相关问题

识别公式

Sub 是否用公式()

Dim r As Range, r1 As Range

Set r = ActiveSheet.UsedRange

For Each r1 In r

    If r1.HasFormula Then
'    判断是否使用公式，是的话返回true
    r1.Font.Color = vbYellow
    
    End If
    
Next r1

End Sub

判断用的公式是什么

在这里插入图片描述

Sub 用的是什么公式()
MsgBox Cells(13, 1).Formula
End Sub

如果没有用公式，则返回的是他的数值，同.value

用VBA实现仅粘贴数值
可以写为

Sub 粘贴数值()
Dim i As Long, j As Long, s As Long
Dim r As Range, w As Worksheet
Dim r1 As Range
For Each w In Worksheets

s = 0

Set r = w.UsedRange

    For Each r1 In r
    '把所选表中的每个cell看成一个小range
    r1.Value = r1.Value
    '取的是公式的值，然后再赋给公式就ok
    
    Next r1
    
    w.Cells(1, 1) = s
    '累加结果返回到工作簿A1
Next w
End Sub

定义新的r.cells

Sub readcells1()
Dim i As Long, j As Long, r As Range
Set r = Range("B3:E11")
For i = 1 To r.Rows.Count
    For j = 1 To r.Columns.Count
        r.Cells.Font.Color = vbRed
        '设定好r的范围，那么r.cells
        '以r为range，从左到右开始重新算
        '比直接写worksheet.cells方便
    Next j
Next i
End Sub

合并range

Sub 联合()
Dim r1 As Range, r2 As Range, r3 As Range, ru As Range
Set r1 = Range("B1:C2")
Set r2 = Range("C5:D6")
Set r3 = Range("E7:G11")
'设置三个区域
Set ru = Application.Union(r1, r2, r3)
'将三个区域合并
ru.Interior.Color = vbRed

End Sub

在这里插入图片描述

算交叉range


Sub 交集()
Dim r1 As Range, r2 As Range, r3 As Range, ru As Range
Set r1 = Range("B1:C2")
Set r2 = Range("C1:D6")
Set r3 = Range("A1:G11")
'设置三个区域
Set ru = Application.Intersect(r1, r2, r3)
'将三个区域交叉的部分选出
ru.Interior.Color = vbYellow

End Sub

算包含range的最大使用区域

在这里插入图片描述

Sub regiondemo()
Dim r As Range, rtable As Range
For Each r In ActiveSheet.UsedRange
Set rtable = r.CurrentRegion
'涉及到的最大区域
rtable.Interior.Color = vbBlue
'上色为蓝色
Next r
End Sub

重新规划range和加一个偏移

Sub regiondemo()
Dim r As Range, rtable As Range, r2 As Range
For Each r In ActiveSheet.UsedRange
r.CurrentRegion.Resize(2, 3).Interior.Color = vbYellow
'涉及到的最大区域,重新规划一个区域
'上色为蓝色
Set r2 = r.Offset(3, 2)
offset 用负数表示左，上
r2.Interior.Color = vbGreen
'在r的基础上加一个偏移
Next r
End Sub

处理整行或整列

Sub 处理行和列()
Dim r As Range
Set r = ActiveSheet.Rows(2)
'记得给row加s
r.Interior.Color = vbRed
Set r = ActiveSheet.Columns("A:E")
r.Interior.Color = vbYellow
'记得给rows里面加双引号

End Sub

合并单元格

在VBA中，合并了单元格，但是仍然视为各自独立，4合一，循环还是跑4次
第一个单元格显示值，后面显示空

如果完全合并，
range(“C1:D2”).mergecells : True
完全不合并为False，部分合并为NULL

Sub mergetest()
Dim r As Range
Set r = Range("C4:D6")

If r.MergeCells Then
MsgBox "完全合并"

ElseIf Not r.MergeCells Then
MsgBox "完全不合并"

ElseIf IsNull(r.MergeCells) Then
MsgBox "部分合并"

End If
End Sub

合并和解除合并

Sub mergetest2()
Dim r As Range
Set r = Range("c4:D6")
'r.MergeCells = True
'r.merge
上述两个是同样的意思
'r.merge true
'按行合并
r.MergeCells = False
End Sub

select的用法

比较录制宏的效率

原始宏代码

在这里插入图片描述

Sub 原始录制宏()
Dim s(), r As Range, i As Long, j As Long
Dim t
t = Timer
Set r = Range("A1:T50")
For i = 1 To r.Rows.count

    For j = 1 To r.Columns.count
        r(i, j).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Next j
Next i

MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

合并掉select

在这里插入图片描述

Sub 合并select()
Dim s(), r As Range, i As Long, j As Long
Dim t
t = Timer
Set r = Range("A1:T50")
For i = 1 To r.Rows.count

    For j = 1 To r.Columns.count
        
    With r(i, j).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With r(i, j).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Next j
Next i

MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

删掉不需要的功能

在这里插入图片描述

Sub 删掉不必要的功能t()
Dim s(), r As Range, i As Long, j As Long
Dim t
t = Timer
Set r = Range("A1:T50")
For i = 1 To r.Rows.count

    For j = 1 To r.Columns.count
        
r(i, j).Interior.Color = vbRed
r(i, j).Font.Color = -16776961
    Next j
Next i

MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

合并点号

在这里插入图片描述

Sub 合并select()
Dim s(), r As Range, i As Long, j As Long
Dim t
t = Timer
Set r = Range("A1:T50")
For i = 1 To r.Rows.count

    For j = 1 To r.Columns.count
With r(i, j)
            .Interior.Color = vbBlue
            .Font.Color = -16776961
            End With
    Next j
Next i

MsgBox "运行时间为" & Timer - t & "秒"  '测试程序运行时间
End Sub

录制宏小结

减少select和selection
减少不用的属性
减少点号

来源：CSDN

作者：高开低走。

链接：https://blog.csdn.net/qq_43568982/article/details/103919053

标签

vba数组

vba

sub

全民一起VBA提高篇第四课：深入理解单元格

range相关

判断一共有多少行

找最后一行结合cells

针对不规则的range，利用usedrange来找范围

找最后一行或者列

二维数组

确定上下界

扫描每个表内红色字体的数字求和

自定义公式的相关问题

识别公式

判断用的公式是什么

定义新的r.cells

合并range

算交叉range

算包含range的最大使用区域

重新规划range和加一个偏移

处理整行或整列

合并单元格

合并和解除合并

select的用法

原始宏代码

合并掉select

删掉不需要的功能

合并点号

录制宏小结