麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range, E As Range, T As Single, i As Integer, R_Add As String
Set Rng(1) = Sheet1.[b24:b25]
Set Rng(2) = Sheet1.[b2:f20]
For Each E In Rng(1)
Application.FindFormat.Interior.ColorIndex = E.Interior.ColorIndex
'FindFormat 設定或傳回要尋找之儲存格格式類型的搜尋準則。
Set Rng(3) = Rng(2).Find(What:="", SearchFormat:=True)
If Not Rng(3) Is Nothing Then R_Add = Rng(3).Address
i = 0
T = 0
Do While Not Rng(3) Is Nothing
i = i + 1
T = T + Rng(3)
Set Rng(3) = Rng(2).Find(What:="", After:=Rng(3), SearchFormat:=True)
If R_Add = Rng(3).Address Then Exit Do
Loop
E.Offset(, 1) = T
E.Offset(, 2) = i
Next
Application.FindFormat.Clear ' 清除 FindFormat 設定要尋找之儲存格格式類型的搜尋準則。
End Sub

複製代碼

'---------------------------------------------------------------------
' ColorIndex Function
'---------------------------------------------------------------------
' Function: Returns the colorindex of the supplied range
' Synopsis: Initially, gets a colorindex value for black and white
' from the activeworkbook colour palette
' Then works through each cell in the supplied range and
' determines the colorindex, and adds to array
' Finishes by returning acumulated array
' Variations: Determines cell colour (interior) or text colour (font)
' Default is cell colour
' Constraints: Does not count colours set by conditional formatting
'---------------------------------------------------------------------
Function ColorIndex(rng As Range, _ Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant
If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If
iWhite = WhiteColorindex(rng.Worksheet.Parent)
iBlack = BlackColorindex(rng.Worksheet.Parent)
If rng.Cells.Count = 1 Then
If text Then
aryColours = DecodeColorIndex(rng, True, iBlack)
Else
aryColours = DecodeColorIndex(rng, False, iWhite)
End If
Else
aryColours = rng.Value
i = 0
For Each row In rng.Rows
i = i + 1
j = 0
For Each cell In row.Cells
j = j + 1
If text Then
aryColours(i, j) = _
DecodeColorIndex(cell, True, iBlack)
Else
aryColours(i, j) = _
DecodeColorIndex(cell, False, iWhite)
End If
Next cell
Next row
End If
ColorIndex = aryColours
End Function
'---------------------------------------------------------------------
Private Function WhiteColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
WhiteColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &HFFFFFF Then
WhiteColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
'---------------------------------------------------------------------
Private Function BlackColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
BlackColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &H0 Then
BlackColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
'---------------------------------------------------------------------
Private Function DecodeColorIndex(rng As Range, _ text As Boolean, _ idx As Long)
'---------------------------------------------------------------------
Dim iColor As Long
If text Then
iColor = rng.Font.ColorIndex
Else
iColor = rng.Interior.ColorIndex
End If
If iColor < 0 Then
iColor = idx
End If
DecodeColorIndex = iColor
End Function
'---------------------------------------------------------------------
' End of ColorIndex Function
'---------------------------------------------------------------------

複製代碼

Function MyColor(Rng As Range, MyIndex As Long) As Long
Dim A As Range, C As Range
For Each C In Rng.Cells
MyColor = MyColor + IIf(C.Interior.ColorIndex = MyIndex, 1, 0)
Next
End Function

複製代碼

Sub PopulateRangeWithArray()
Dim x
ReDim x(1 To 2, 1 To 2)
x(1, 1) = String(2000, "a"): x(1, 2) = String(5000, "b")
x(2, 1) = String(17000, "c"): x(2, 2) = String(33000, "d")
MsgBox Len(x(1, 1)) & "," & Len(x(1, 2)) _
& "," & Len(x(2, 1)) & "," & Len(x(2, 2))
Range("a1").Value = x(1, 1)
Range("b1").Value = x(1, 2)
Range("a2").Value = x(2, 1)
Range("b2").Value = x(2, 2)
End Sub

複製代碼

Sub ex()
Dim ar()
'2003的Rows.Count=65536
ReDim ar(0 To Rows.Count + 1)
ar(Rows.Count + 1) = Rows.Count
MsgBox ar(Rows.Count + 1)
End Sub

複製代碼