Excel VBA質問箱 IV

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

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


9158 / 13644 ツリー ←次へ | 前へ→

【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 回答[未読]

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

引用なし
パスワード
   こんにちわ。
同じ列に複数の同じ名前のデーターがあるのか無いのかわからない・・・
そこで、それを検索してあれば色を変えて、同じ項目データがある場所を隣の列に表示してくれる。
そんなマクロを作ろうとがんばっていました

が、

だめでした。。。何度やってもだめでした。
お助け下さい。

イメージ:

A列      B列      C列
12345      001      佐藤商事
12346      001      加藤商事
12347      001      伊藤商事
12345      002      佐藤商事
12347      003      佐藤商事

↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

A列      B列      C列            D列
12345      001      佐藤商事←色が変わってる  A4,A5
12346      001      加藤商事
12347      001      伊藤商事
12345      002      佐藤商事←色が変わってる  A1,A5
12347      003      佐藤商事←色が変わってる  A1,A4


よろしくお願い致します。

【28991】Re:同列内複数項目
回答  ちくたく  - 05/9/20(火) 15:31 -

引用なし
パスワード
   こんにちは。

ものすごい酷いコードですが(笑)。
昔ながら的にやるならこんな感じでしょうか?
ほんとに合ってるのかわかりませんが。

Sub 重複項目()
  Dim endCRow As Integer
  Dim i As Integer, j As Integer
  
  endCRow = CInt(Range("C65536").End(xlUp).Row)
  
  For i = 1 To endCRow
    For j = 2 To endCRow
      If i <> j And Range("C" & i).Value = Range("C" & j).Value Then
        Range("D" & j).Value = Range("D" & j).Value & "C" & i
        Range("C" & j).Interior.ColorIndex = 3
      End If
    Next j
  Next i
End Sub

【29003】Re:同列内複数項目
回答  Statis  - 05/9/21(水) 8:19 -

引用なし
パスワード
   こんにちは

お試しを。

Sub test()
Dim Da, i As Long, Ro As Long, j As Long
Ro = Range("C65536").End(xlUp).Row
Da = Range("C1:D" & Ro).Value
For i = 1 To UBound(Da)
  For j = 1 To UBound(Da)
    If i <> j Then
      If Da(i, 1) = Da(j, 1) Then
       Cells(i, 3).Interior.ColorIndex = 6
       Da(i, 2) = Da(i, 2) & " C" & j
      End If
    End If
  Next j
Next i
Range("C1:D" & Ro).Value = Da
End Sub

【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

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