Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

52539 / 76732

←次へ　｜　前へ→


	【29030】Re:同列内複数項目

Hirofumi - 05/9/21(水) 22:55 -


	引用なし

	パスワード

長いコードに成っちゃたけど？

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

0 hits

▼

【28990】同列内複数項目 Help me!! 05/9/20(火) 15:13