Option Explicit
 
Declare Function GetTickCount Lib "kernel32" () As Long
 
Dim intI As Integer
 
Dim lngI As Long
Dim lngRow As Long
Dim lngCol As Long
Dim lngSTime As Long
Dim lngETime As Long
Dim lngRowsC As Long
Dim lngColsC As Long
Dim lngIndex As Long
Dim lngSelCellsR As Long
Dim lngSelCellsC As Long
 
Dim strAddress As String
Dim strAddressSec As String
 
Dim varI As Variant
Dim varData() As Variant
 
Dim objRange As Range
 
Const conC As String = ","
Const conRow As String = ",R"
Const conCol As String = "C"
 
Sub Speed_Test()
 
    With Excel.Application
 
        If TypeName(.Selection) <> "Range" Then Exit Sub
 
        .ScreenUpdating = False
 
        With .Selection
 
            If .Cells.Count = 1 Then
 
                MsgBox "単一セルではなく､セル範囲を選択してください｡"
 
                Exit Sub
 
            End If
 
            If 1 < .Areas.Count Then
 
                MsgBox "一つのセル範囲を選択してください。"
 
                Exit Sub
 
            End If
 
            For intI = 1 To 10 'テスト回数
 
                Call Test_1
                Call Test_2
                Call Test_3
                Call Test_4
                Call Test_5
                Call Test_6
 
            Next intI
 
        End With
 
        .ScreenUpdating = True
 
    End With
 
End Sub
 
Private Sub Test_1()
 
    lngSTime = GetTickCount
 
    For Each objRange In Selection
 
        If objRange.Value = 1 Then objRange.Interior.ColorIndex = 6
 
    Next objRange
 
    lngETime = GetTickCount
    ActiveSheet.Cells(1 + intI, 1).Value = lngETime - lngSTime
    Selection.Interior.ColorIndex = xlNone
 
End Sub
 
Private Sub Test_2()
 
    lngSTime = GetTickCount
    lngIndex = 0
 
    With Selection
 
        lngRowsC = .Rows.Count  '選択範囲の行数
        varData = .Value        '選択範囲の値をバリアント変数に代入
 
        For Each varI In varData
 
            lngIndex = lngIndex + 1
 
            If varI = 1 Then
 
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                .Cells(lngRow, lngCol).Interior.ColorIndex = 6
 
            End If
 
        Next varI
 
        lngETime = GetTickCount
 
    End With
 
    ActiveSheet.Cells(1 + intI, 2).Value = lngETime - lngSTime
    Selection.Interior.ColorIndex = xlNone
 
End Sub
 
Private Sub Test_3()
 
    lngSTime = GetTickCount
 
    With Selection
 
        lngRowsC = .Rows.Count
        lngColsC = .Columns.Count
        varData = .Value
 
        For lngRow = 1 To lngRowsC
 
            For lngCol = 1 To lngColsC
 
                If varData(lngRow, lngCol) = 1 Then .Cells(lngRow, lngCol).Interior.ColorIndex = 6
 
            Next lngCol
 
        Next lngRow
 
    End With
 
    lngETime = GetTickCount
    ActiveSheet.Cells(1 + intI, 3).Value = lngETime - lngSTime
    Selection.Interior.ColorIndex = xlNone
 
End Sub
 
Private Sub Test_4()
 
    lngSTime = GetTickCount
    lngIndex = 0
    strAddress = vbNullString
 
    With Selection
 
        lngRowsC = .Rows.Count
        varData = .Value
 
        For Each varI In varData
 
            lngIndex = lngIndex + 1
 
            If varI = 1 Then
 
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                strAddress = .Cells(lngRow, lngCol).Address(False, False)
                ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
 
            End If
 
        Next varI
 
    End With
 
    lngETime = GetTickCount
    ActiveSheet.Cells(1 + intI, 4).Value = lngETime - lngSTime
    Selection.Interior.ColorIndex = xlNone
 
End Sub
 
Private Sub Test_5()
 
    lngSTime = GetTickCount
    lngIndex = 0
    strAddress = vbNullString
    strAddressSec = vbNullString
 
    With Selection
 
        lngRowsC = .Rows.Count
        varData = .Value
 
        For Each varI In varData
 
            lngIndex = lngIndex + 1
 
            If varI = 1 Then
 
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                strAddressSec = conC & .Cells(lngRow, lngCol).Address(False, False)
 
                If 255 < Len(strAddress) + Len(strAddressSec) Then
 
                    GoSub JoinString
 
                Else
 
                    strAddress = strAddress & strAddressSec
 
                End If
 
            End If
 
        Next varI
 
        If 0 < Len(strAddress) Then GoSub JoinString
 
    End With
 
 
    lngETime = GetTickCount
    ActiveSheet.Cells(1 + intI, 5).Value = lngETime - lngSTime
    Selection.Interior.ColorIndex = xlNone
 
Exit Sub
 
JoinString:
    strAddress = Mid$(strAddress, 2)
    ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
    strAddress = vbNullString
 
    Return
 
End Sub
 
Private Sub Test_6()
 
    lngSTime = GetTickCount
    lngIndex = 0
    strAddress = vbNullString
 
    With Selection
 
        lngRowsC = .Rows.Count
        varData = .Value
        strAddress = .Cells(1, 1).Address(ReferenceStyle:=xlR1C1) '選択範囲の左上アドレスをR1C1で取得
        strAddress = Mid$(strAddress, 2)
        lngI = InStr(1, strAddress, conCol, vbTextCompare)
        lngSelCellsR = CLng(Left$(strAddress, lngI - 1)) - 1  '行を取り出し
        lngSelCellsC = CLng(Mid$(strAddress, lngI + 1)) - 1   '列を取り出し
        strAddress = vbNullString
        strAddressSec = vbNullString
 
        For Each varI In varData
 
            lngIndex = lngIndex + 1
 
            If varI = 1 Then
 
                'シート上での行番号
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1 + lngSelCellsR
                'シート上での列番号
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC + lngSelCellsC
                'R1C1参照として書き出し
                strAddressSec = conRow & lngRow & conCol & lngCol
 
                If 255 < Len(strAddress) + Len(strAddressSec) Then
 
                    GoSub JoinAddress
 
                Else
 
                    strAddress = strAddress & strAddressSec
 
                End If
 
            End If
 
        Next varI
 
        If 0 < Len(strAddress) Then GoSub JoinAddress
 
    End With
 
    lngETime = GetTickCount
    ActiveSheet.Cells(1 + intI, 6).Value = lngETime - lngSTime
'    Selection.Interior.ColorIndex = xlNone
 
Exit Sub
 
JoinAddress:
 
    strAddress = Mid$(strAddress, 2)
    strAddress = Application.ConvertFormula(strAddress, xlR1C1, xlA1, xlRelative)
    ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
    strAddress = strAddressSec
 
    Return
 
End Sub