| 
    
     |  | ▼アーサー さん: こんばんは。
 
 >こんなこと出来ないでしょうか?
 
 1行目が
 
 >  A   B   C   D   E   F   G   H
 >1 5B  3Y  1A  3Y  4B  5B  1A  3Y
 >
 となっているデータから、
 
 >     ↓
 >
 >  A    B    C   D
 2 1A×2 3Y×3 4B  5B×2
 
 2行目に上記にまとめる事を考えると・・・、
 
 
 標準モジュールに
 '=============================================================
 Sub main()
 Dim col As Long
 Dim k As Variant
 Dim crng As Range
 Dim rng As Range
 Dim dic As Object
 Set dic = CreateObject("scripting.dictionary")
 Set rng = Range("a1", Cells(1, 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
 For Each k In .Keys
 If .Item(k) = 1 Then
 Cells(2, col).Value = k
 Else
 Cells(2, col).Value = k & " × " & .Item(k)
 End If
 col = col + 1
 Next
 Range("A2", Cells(2, col)).Sort Key1:=Range("A2"), _
 Order1:=xlAscending, Header:=xlNo, _
 OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlLeftToRight, SortMethod _
 :=xlPinYin, DataOption1:=xlSortNormal
 End With
 Set dic = Nothing
 End Sub
 
 これで試してみてください。
 
 |  |