| |
長いコードに成っちゃたけど？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim rngList As Range
Dim dicIndex As Object
Dim vntData As Variant
Dim vntResult As Variant
Dim vntRow As Variant
Dim lngColor As Long
Dim lngNumb As Long
Dim strProm As String
'データの先頭セル位置を設定
Set rngList = ActiveSheet.Cells(1, "C")
'データを配列に読み込み
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Resize(lngRows).Value
End With
ReDim vntResult(1 To lngRows, 1 To 1)
Application.ScreenUpdating = False
'Dictionaryオブジェクトのインスタンスを作成
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'データの先頭から最終まで繰り返し
For i = 1 To lngRows
'データが""で無い場合
If vntData(i, 1) <> "" Then
'インデックスにデータが有る場合（重複の場合）
If .Exists(vntData(i, 1)) Then
'重複の先頭行位置を取得
lngNumb = .Item(vntData(i, 1))
'初めて重複する場合
If vntData(lngNumb, 1) = -1 Then
'配列の重複の先頭行位置にパレット番号を格納
vntData(lngNumb, 1) = (lngColor Mod 16) + 33
'重複する行番号の配列を作成
ReDim vntRow(1 To 1)
vntRow(1) = lngNumb
vntResult(lngNumb, 1) = vntRow
'セルの重複先頭行位置をパレット番号の色にする
rngList.Offset(lngNumb - 1).Interior.ColorIndex _
= vntData(lngNumb, 1)
'色数を更新
lngColor = lngColor + 1
End If
'重複行位置をパレット番号の色にする
vntData(i, 1) = vntData(lngNumb, 1)
rngList.Offset(i - 1).Interior.ColorIndex _
= vntData(lngNumb, 1)
'重複行位置を記録
vntRow = vntResult(lngNumb, 1)
ReDim Preserve vntRow(1 To UBound(vntRow, 1) + 1)
vntRow(UBound(vntRow, 1)) = i
vntResult(lngNumb, 1) = vntRow
Else
'インデクスにKeyと行位置を追加
.Add vntData(i, 1), i
'行位置のパレット番号を-1に
vntData(i, 1) = -1
End If
End If
Next i
'登録されているItemを取得
vntData = .Items
End With
Set dicIndex = Nothing
'Offsetの元の値を取得
lngNumb = rngList.Row
'Itemに就いて繰り返し
For i = 0 To UBound(vntData, 1)
'もしItemの示す配列要素が配列なら
If VarType(vntResult(vntData(i), 1)) = vbArray + vbVariant Then
'配列を取り出す
vntRow = vntResult(vntData(i), 1)
'重複行をのListを作成
For j = 1 To UBound(vntRow, 1)
strProm = ""
For k = 1 To UBound(vntRow, 1)
If vntRow(j) <> vntRow(k) Then
If strProm <> "" Then
strProm = strProm & ", "
End If
strProm = strProm & "C" & (vntRow(k) + lngNumb - 1)
End If
Next k
'出力用配列にListを書き込み
vntResult(vntRow(j), 1) = strProm
Next j
End If
Next i
'重複Listを出力
rngList.Offset(, 1).Resize(lngRows).Value = vntResult
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set rngList = Nothing
Beep
MsgBox strProm
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
