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
2 hits

【28990】同列内複数項目 Help me!! 05/9/20(火) 15:13 質問
【28991】Re:同列内複数項目 ちくたく 05/9/20(火) 15:31 回答
【29003】Re:同列内複数項目 Statis 05/9/21(水) 8:19 回答
【29030】Re:同列内複数項目 Hirofumi 05/9/21(水) 22:55 回答

52539 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free