| |
こんな事なのかなぁ？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim lngTop As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim strProm As String
'Listの左上隅セル位置を基準として設定
Set rngList = ActiveSheet.Cells(5, "G")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
' 'データ行数を取得 ★データ行数が不定で行数を取得する場合
' lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
' 'データが無い場合
' If lngRows <= 1 And .Value = "" Then
' strProm = "データが有りません"
' GoTo Wayout
' End If
'データ行数を設定(G5〜G19) ★データ行数を予め指定する場合
lngRows = 15
'データを配列に取得
vntData = .Resize(lngRows + 1).Value
'番兵を設定
vntData(lngRows + 1, 1) = Empty
'範囲のフォントを初期化
.Resize(lngRows).Font.ColorIndex = 0
'同一セル値の先頭行初期値設定
lngTop = 1
'同一セル値のカウント初期値設定
lngCount = 1
'データ2行目〜最終行+1まで繰り返し
For i = 2 To lngRows + 1
'同一セル値先頭と現在行の値が違った場合
If vntData(lngTop, 1) <> vntData(i, 1) Then
'同一セル値先頭が""で無いなら
If vntData(lngTop, 1) <> "" Then
With .Offset(lngTop - 1)
'同一値が1超える場合
If lngCount > 1 Then
'FontColorをWhiteに
.Resize(lngCount - 1).Font.Color = vbWhite
End If
'FontColorをBlackに
.Offset(lngCount - 1).Font.Color = vbBlack
End With
End If
'同一セル値の先頭行を更新
lngTop = i
'同一セル値のカウント初期値設定
lngCount = 1
Else
'同一セル値のカウントを更新
lngCount = lngCount + 1
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
