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

最新推荐文章于 2020-03-29 15:51:43 发布

高开低走。

最新推荐文章于 2020-03-29 15:51:43 发布

阅读量624

点赞数

分类专栏：锦到说VBA

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

版权

锦到说VBA 专栏收录该内容

37 篇文章 24 订阅

订阅专栏

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