VBAで出来ますか？

質問

EXCELで困ってます。
複数の列にあるデータをカウントしたいのです。
例えば↓の様なデータがあります。

名前　値　　値　　値　　値
あか　1-1 　1-2 　2-5 　7-3
あお　7-3 　8-3 　1-1
かい　2-5 　7-3 　8-3 　1-2 　
うみ　1-2 　2-5 　7-3

どんな値が何個あるのか？
その値はどの名前にあるのか？
オートフィルタを使ったり、
ピボットテーブルを利用したりしましたが、
なかなかうまく出来ません。
例だと、

値　個数　名前
1-1　2　　あか　あお
1-2　3　　あか　かい　うみ　
2-5　3　　あか　かい　うみ
7-3　4　　あか　あお　かい　うみ
8-3　2　　あお　かい

以上のような感じのものが欲しいのです。
別のシートに出来ると嬉しいです。
実際は、値の列が１０個あります。
名前は、1000個ぐらいあります。
どうか、よろしくお願いします。

回答No.3

ja7awu · ベストアンサー

データのあるシートをアクティブにした状態で次のマクロを実行すると、
そのシートの右側に集計されたシートが出来ます。
シート名は、現在の名前+(集計)です。
実行時、すでにこの名前が、存在している場合は、削除後に新しく作成
されます。何回実行してもＯＫです。

Sub Macro1()
Dim NewSh As Worksheet
Dim Rng As Range
Dim Rw As Long
Dim Col As Integer
Dim SName As String
Dim Dt As String
Dim N As Integer
SName = ActiveSheet.Name
Application.DisplayAlerts = False
For N = 1 To Sheets.Count
　　If Sheets(N).Name = SName & "(集計)" Then
　　　　Sheets(N).Delete
　　　　Exit For
　　End If
Next N
Sheets.Add After:=Sheets(SName)
Set NewSh = ActiveSheet
NewSh.Name = SName & "(集計)"
For N = 1 To 3
　　Cells(1, N).Value = Choose(N, "値", "個数", "名前")
Next N
Rows(1).HorizontalAlignment = xlCenter
Columns(1).NumberFormatLocal = "@"
Sheets(SName).Select
Rw = Range("A1").CurrentRegion.Rows.Count
Col = Range("A1").CurrentRegion.Columns.Count
On Error GoTo nai
For Each Rng In Range("B2").Resize(Rw - 1, Col - 1)
　　Dt = Rng.Value
　　If Dt <> vbNullString Then
　　　　N = Application.WorksheetFunction. _
　　　　　　Match(Dt, NewSh.Range("A:A"), 0)
　　　　If N = 0 Then
　　　　　　With NewSh.Range("A65536").End(xlUp)
　　　　　　　　.Offset(1).Value = Dt
　　　　　　　　.Offset(1, 1).Value = .Offset(1, 1).Value + 1
　　　　　　　　.Offset(1).End(xlToRight).Offset(, 1) = _
　　　　　　　　　　Cells(Rng.Row, 1).Value
　　　　　　End With
　　　　Else
　　　　　　With NewSh.Range("A" & N)
　　　　　　　　.Value = Dt
　　　　　　　　.Offset(, 1).Value = .Offset(, 1).Value + 1
　　　　　　　　.End(xlToRight).Offset(, 1) = Cells(Rng.Row, 1).Value
　　　　　　End With
　　　　End If
　　End If
Next Rng
nai:
N = 0
Resume Next
Application.DisplayAlerts = True
Set NewSh = Nothing
End Sub

お礼

回答ありがとうございます。
早速やってみました。
今までの作業が一瞬で出来ているので感動です。
本当にありがとうございました。

回答No.2

imogasi

＃１です。コーディング例を挙げます。
（１）
Sub test01()
d = Range("a1").CurrentRegion.Rows.Count
MsgBox d
k = 1
For i = 2 To d
For j = 2 To 10
If Worksheets("sheet1").Cells(i, j) = "" Then Exit For
Worksheets("sheet2").Cells(k, 1) = "'" & Worksheets("sheet1").Cells(i, j)
Worksheets("sheet2").Cells(k, 2) = Worksheets("sheet1").Cells(i, 1)
k = k + 1
Next j
Next i
End Sub
（２）手操作でＡ列をキーとしてソートしてください。
ＶＢＡでも出来ますが、今回は略。
（３）Sub test02()
d = Worksheets("sheet2").Range("a1").CurrentRegion.Rows.Count
MsgBox d
k = 1
j = 2
m = Worksheets("sheet2").Cells(1, 1)
Worksheets("sheet3").Cells(1, 1) = Worksheets("sheet2").Cells(1, 1)
For i = 1 To d
If Worksheets("sheet2").Cells(i, 1) = m Then
Worksheets("sheet3").Cells(k, j) = Worksheets("sheet2").Cells(i, 2)
j = j + 1
Else
k = k + 1
Worksheets("sheet3").Cells(k, 1) = Worksheets("sheet2").Cells(i, 1)
Worksheets("sheet3").Cells(k, 2) = Worksheets("sheet2").Cells(i, 2)
j = 2 + 1
m = Worksheets("sheet2").Cells(i, 1)
End If
Next i
End Sub
件数を出し忘れていますがよろしく。

お礼

回答ありがとうございます。
早速、やってみます。
ありがとうございます。

回答No.1

imogasi

ロジックの１例を述べます。
（１）ある列について、B列から空白列まで右に進んで、「各列の値－A列の名前値」のペアのデータレコードを作ります。
それを最下行までに亘ってレコードを作ります。テキスト形式で作ります。
（２）「各列の値」の方で全レコードをソートします。
（３）「各列の値」のレコードは固まりますから、名前のバラエティをＣ列以下に展開しその数をＢ列にセットします。全ての「各列の値」のバラエティについて、下の行に展開します。