''application.Union 方法
''返回两个或多个区域的合并区域
Sub uniontext()
Sheet4.Range("a1:b3,c5:d8").Select
Union([a1:b3], [c5:d8]).Select
End Sub
'range也可以完成多区域引用
'单文本地址的引用方式最多不超过256个字符, 但是union没有这个限制
Sub 连接符单元格连接()
Dim rng As Range
For Each rng In [b2:b10]
adress = rng.address
Sadress = Sadress & adress + ","
Next
Sadress = Left(Sadress, Len(Sadress) - 1)
Range(Sadress).Select
End Sub
Sub union单元格连接() 'union必须为对象
Dim rng As Range
Dim rngs As Range
Set rng = [b2] '先申明一个变量
For Each rngs In [b2:b10]
address = rngs.address
Set rng = Union(rng, rngs) ''合并起来赋值给rng
Saddress = rng.address
Next
End Sub
Sub 条件筛选()
Dim rng As Range
For Each rng In Range([b2], Cells(Cells.Find("*", , , , , xlPrevious).Row, 2)) '对B2列
If rng.Value > 90 Then ''进行判断
k = k + 1
Range("D" & k) = rng.Offset(0, -1) ''使用偏移进行赋值
Range("E" & k) = rng
End If
Next
End Sub
Sub S条件筛选()
Dim rng, rn, Sng As Range
For Each rng In Range([b2], Cells(Cells.Find("*", , , , , xlPrevious).Row, 2)) '对B2列
If rng.Value > 90 Then ''进行判断
k = k + 1
If k = 1 Then
Set rn = rng
Else
Set rn = Union(rn, rng) ' 前面的单元格 连上现在的单元格
aa = rn.address
End If
End If
Next
''对满足条件的区域进行循环
For Each Sng In rn
s = s + 1
Cells(s, "d") = Cells(Sng.Row, "a") ''满足条件单元格所在的行
Cells(s, "e") = Sng
Next
End Sub
''===============================
''单元格交集application.intersect
'返回一个range对象 表示2个或多个区域重叠的部分
Sub Intersect()
Worksheets(1).Activate
Dim isect As Range
Set isect = Application.Intersect(Range("a28:c36"), Range("c35:d32"))
If isect Is Nothing Then
MsgBox "Ranges do not intersect"
Else
'Application.Intersect(Sheet4.Range("a28:c36"), Sheet4.Range("c35:d32")).Select
End If
End Sub
Sub 隔行插入Intersect() ''插入空行
For i = 0 To Application.CountA(Columns(1)) * 2 Step 2
Application.Intersect(Range("a1:d2").Offset(i), Range("a2:d3").Offset(i)).EntireRow.Insert
''A1：d2 and D2:D3 在相交的区域插入空行
Next
End Sub
'''获取单元格格式
Sub 获取单元格设置数字格式()
For Each rng In [a1:c1]
Cells(2, rng.Column) = rng.NumberFormatLocal ''获取单元格的格式代码
' Cells(3, rng.Column) = rng.NumberFormatLocal
' Cells(4, rng.Column) = rng.NumberFormatLocal
Next
End Sub
Sub 给单元格设置数字格式()
For Each rng In [a1:c3]
rng.NumberFormatLocal = "0.00"
Sheet4.Cells(4, 1).Resize(4).NumberFormatLocal = "e-m-d aaaa" ''已cells(4,1) 调整大小向右再选4行 设置单元格格式 YYYY-M-D 星期日
Next
End Sub
Sub 保存111()
Set rng = Cells.Find("*", , , , , xlPrevious)
a = Application.CountA(Sheet1.Range("a:a"))
a = Sheet1.Cells.Find("*", , , , , xlPrevious).Row
Sheet1.Range("a5", "e" & a).Copy Sheet4.Cells(a + 1, 1)
End Sub
''Font对象 包含对象的字体属性（字体名字,字号,颜色等等）
'range.clearformats ''清除对象的格式设置
Sub font属性()
With [a2:a6].Font
.name = "微软雅黑" '字体
.Size = 8 '字号
.Bold = True '加粗
.Color = RGB(255, 0, 255) '颜色
.ColorIndex = 7 '颜色
End With
End Sub
Sub 大于90分颜色设置()
Dim a As Range
Dim rng As Range
Sheet1.Cells(Rows.Count, 1).End(xlUp).Select
Set a = Cells(Rows.Count, 1).End(xlUp) ''最后单元格向上移动
Range("a1", a).ClearFormats
For Each rng In Range("a1", a)
If rng.Value > 90 Then
With rng.Font
.name = "华文琥珀"
.Size = 9
.Bold = True
.Color = RGB(255, 0, 255)
End With
End If
Next
End Sub
''Interior 对象
''代表一个对象的内部
Sub 单元格底部颜色() ''颜色索引值
For i = 1 To 56
Sheet4.Cells(i, 1).Interior.ColorIndex = i
Sheet4.Cells(i, 2) = i
Next
End Sub
Sub 早期颜色值()
For i = 0 To 15 ''16中颜色
Cells(i + 1, 4).Interior.Color = QBColor(i)
Cells(i + 1, 5) = i
Next
End Sub
Sub 三原色()
Cells(2, 8).Interior.Color = RGB([H1], [I1], [J1])
End Sub
Sub 直接颜色() '此颜色有 255*255*255 中颜色
Cells(3, 8).Interior.Color = 10
End Sub
Sub 实例格式化单元格()
Dim i%
i = Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To i
If j Mod 2 Then ''如果有余数 'EntireRow 整行
''range.range 它是以默认前面单元格中的左上单元格为准 对前面整行的 A1：G1
With Cells(j, 1).EntireRow.Range("a1:g1").Font
.Bold = True
.Size = 9
.ColorIndex = 3
End With
Else
Cells(j, 1).EntireRow.Range("a1:g1").Interior.ColorIndex = 40
End If
Next
End Sub
Sub 清除格式化() '选择区域清除格式化
Selection.ClearFormats
End Sub
Sub 查找功能拾取颜色求平均分()
On Error GoTo 100
Dim erng As Range, rng As Range, i As Long
i = Application.FindFormat.Interior.Color ''利用 findformat 查找颜色的功能 返回拾取到的颜色值返回给 i
Set erng = Cells(Rows.Count, "e").End(xlUp) ''直接返回最后个单元格
For Each rng In Range("a1", erng)
If rng.Interior.Color = i Then
k = k + rng.Value
n = n + 1
End If
Next
MsgBox k / n
Exit Sub
100:
MsgBox "查找功能没有拾取到颜色"
End Sub
本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请
点击举报。
