1. 技术文章
  2. 全民一起VBA提高篇第四课：深入理解单元格

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

由 ﹥＞﹥吖頭↗ 提交于 2020-02-07 09:26:53

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

录制宏小结

  1. 减少select和selection
  2. 减少不用的属性
  3. 减少点号
标签
vba数组
next
vba
sub
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!