Excel VBA質問箱 IV

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

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


31607 / 76734 ←次へ | 前へ→

【50374】Re:同名を一つのセル内で表示
発言  ponpon  - 07/7/22(日) 0:27 -

引用なし
パスワード
   ▼ゼロワン さん:
>   A   B   C   D   E   F   G
>1 みかん りんご ぶどう りんご いちご ぶどう りんご
>
>               ↓
>
>   A   B     C   D   
>1 いちご ぶどう×2 みかん りんご×3 
>
>となるようにしたいのですが・・・
>この回答は50074で確認することができました。自分が知りたいのは、この行が100、あるいは遥かそれ以上の膨大な行数になった時のコード、もう一つは、1の行の変換は上の例のように、同じ1の行で表示されるようにすること。そのためはじめに表示されているデータは消えても構いません。ようするに同一行に上書きのような形で表示させたいのです。

回答は50074のichinoseさんの回答を行でループさせればよいと思います。
後は、早起きのichinoseさんが手直ししてくれると思いますが、
以下のコードでできると思います。

Sub main()
  Dim col As Long
  Dim myRow As Long
  Dim k As Variant
  Dim crng As Range
  Dim rng As Range
  Dim dic As Object
  
  For myRow = 1 To Range("A65536").End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary")
    Set rng = Range(Cells(myRow, 1), Cells(myRow, Columns.Count).End(xlToLeft))
    With dic
      For Each crng In rng
       If .Exists(crng.Value) = False Then
        .Add crng.Value, 1
       Else
        .Item(crng.Value) = .Item(crng.Value) + 1
        End If
       Next
     
      col = 1
      Rows(myRow).ClearContents
      For Each k In .keys
       If .Item(k) = 1 Then
         Cells(myRow, col).Value = k
       Else
         Cells(myRow, col).Value = k & " × " & .Item(k)
       End If
       col = col + 1
      Next
      Range(Cells(myRow, 1), Cells(myRow, col)).Sort Key1:=Cells(myRow, 1), _
       Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlLeftToRight, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
     End With
     Set dic = Nothing
  Next
End Sub
3 hits

【50372】同名を一つのセル内で表示 ゼロワン 07/7/21(土) 21:43 質問
【50373】Re:同名を一つのセル内で表示 ゼロワン 07/7/21(土) 21:49 質問
【50374】Re:同名を一つのセル内で表示 ponpon 07/7/22(日) 0:27 発言

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