VBA数组与单元格格式

'数组也可以设置格式？

'数组除了数字类型外，当然没有颜色、字体等格式，但是别忘了range对象可以表示多个连续或不连续的单元格区域

'利用上述特点，我们就是要数组构造单元格地址串，然后批量对单元格进行格式设置。

'注意，单元格地址串不能>255，所以如果单元格操作过多，我们还需要分次分批设置单元格格式

Sub 填充颜色()

Range('a2:d2,a7:d7,a10:d10').Interior.ColorIndex = 3

End Sub

Option Explicit

Sub 单元格循环()

Dim x As Integer

Dim t

清除颜色

t = Timer

For x = 2 To Range('a65536').End(xlUp).Row

If Range('d' & x) > 500 Then

Range(Cells(x, 1), Cells(x, 4)).Interior.ColorIndex = 3

End If

Next x

MsgBox Timer - t

End Sub

Sub 清除颜色()

Range('a:d').Interior.ColorIndex = xlNone

End Sub

Sub 数组方法()

Dim arr, t

Dim x As Integer

Dim sr As String, sr1 As String

清除颜色

t = Timer

arr = Range('d2:d' & Range('a65536').End(xlUp).Row)

For x = 1 To UBound(arr)

If x = UBound(arr) And sr <> '' Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3

If arr(x, 1) > 500 Then

sr1 = sr

sr = sr & 'A' & x + 1 & ':D' & x + 1 & ','

If Len(sr) > 255 Then

sr = sr1

Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3

sr = ''

End If

End If

Next x

MsgBox Timer - t

End Sub

Sub 数组方法2()

Dim arr, t

Dim x As Integer, x1 As Integer

Dim sr As String, sr1 As String

清除颜色

t = Timer

arr = Range('d2:d' & Range('a65536').End(xlUp).Row)

For x = 1 To UBound(arr)

If x = UBound(arr) Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3

If arr(x, 1) > 500 Then

sr1 = sr

x1 = x + 1

Do

x = x + 1

Loop Until arr(x, 1) <= 500

sr = sr & 'A' & x1 & ':D' & x & ','

If Len(sr) > 255 Then

sr = sr1

x = x1 - 1

Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3

sr = ''

End If

x = x - 1

End If

Next x

MsgBox Timer - t

End Sub

Sub 数组方法3()

Dim arr, t

Dim x As Integer, x1 As Integer

Dim sr As String, sr1 As String

清除颜色

t = Timer

arr = Range('d2:d' & Range('a65536').End(xlUp).Row)

For x = 1 To UBound(arr)

If x = UBound(arr) Then Application.Intersect(Range('a:d'), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3

If arr(x, 1) > 500 Then

sr1 = sr

x1 = x + 1

Do

x = x + 1

Loop Until arr(x, 1) <= 500

sr = sr & x1 & ':' & x & ','

If Len(sr) > 255 Then

sr = sr1

x = x1 - 1

Application.Intersect(Range('a:d'), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3

sr = ''

End If

x = x - 1

End If

Next x

MsgBox Timer - t

End Sub