エクセル DBから該当データを抜き出し帳票へ出力

質問

エクセルについて質問です。
エクセルのバージョンは2007を使用しています。

下記sheet1のようなデータがあるときに、sheet2に月ごとに集計し
順位ごとにまとめてB列にまとめて記載する帳票を作っているのですが

（※ちなみにその形式を説明させていただきますと
　　　該当者がいなければB列には空白を返し
　　　該当者がいる場合はB列に個人ごとにまとめ、
　　　(1)名前、(2)その月にその人がその順位をとった回数《1度のみの時は省略》、そして
　　　括弧の中に(3)4月から積み重ねてその人がその順位をとった回数、(4)その時の場所　を記載し
　　　すべて半コンマ（,）プラス空白で区切ってB列の1セル内に羅列しております）

これをsheet1にデータを入力すれば自動的にsheet2のB列に
今の形式で反映されるようにしたいのです。

エクセルの関数でできるならばもちろんその方法を知りたいのですが
もし不可能であるならばVBA？マクロ？なども勉強して組んでいければと思っています。

今はどのプログラムを使えば自動化できるのかについても理解しておりませんので
どのプログラムをどんなふうに学んでいけばいいのかさえ見当がつかずじまいの状態です。

これを使ってこうすればできるよ、という方法をご存知の方がいらっしゃいましたら
そのさわりの部分、ヒントだけでもかまいませんので教えていただきたいのです。

どうかよろしくお願いいたします。

<sheet1>
　　　 A　　　　 B　　　　　C　　　　　

１　　 月　　　名前　　　成績　　　場所
２　　4月　　　山田　　　1位　　　　甲
３　　4月　　　佐藤　　　2位　　　　乙
４　　5月　　　佐藤　　　2位　　　　甲
５　　5月　　　佐藤　　　2位　　　　甲
６　　5月　　　山田　　　3位　　　　丙
７　　5月　　　佐藤　　　4位　　　　丁
８　　5月　　　山田　　　2位　　　　甲

<sheet2>

　　　　A　　　　B

１　　5月度成績
２
３　　1位　　　空白
４　　2位　　　佐藤2回（3, 甲, 甲）, 山田（1, 甲）
５　　3位　　　山田（1, 丙）
６　　4位　　　佐藤（1, 丁）

回答No.1

tom04 · ベストアンサー

こんばんは！
VBAで無理矢理やってみました。

条件として
（1）Sheet2のA1セルにSheet1の「○月」というデータを入力する。
（2）Sheet2の順位（1位～）はA3セル以降に入力済み
というコトが前提です。

画面左下のSheet2のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k, N, M As Long
Dim str, buf As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
k = Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
On Error Resume Next
If k > 2 Then
Range(Cells(3, 2), Cells(k, 2)).ClearContents
End If
For k = 3 To Cells(Rows.Count, 1).End(xlUp).Row
N = 2
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Cells(i, 1) = Cells(1, 1) And ws.Cells(i, 3) = Cells(k, 1) Then
If WorksheetFunction.CountIf(Rows(k), ws.Cells(i, 2)) = 0 Then
N = N + 1
Cells(k, N) = ws.Cells(i, 2)
End If
End If
Next i
Next k
For k = 3 To Cells(Rows.Count, 3).End(xlUp).Row
For j = 3 To Cells(k, Columns.Count).End(xlToLeft).Column
str = Cells(k, j)
M = 0
N = 0
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Cells(i, 1) = Cells(1, 1) And ws.Cells(i, 2) = str And ws.Cells(i, 3) = Cells(k, 1) Then
M = M + 1
End If
If ws.Cells(i, 2) = str And ws.Cells(i, 3) = Cells(k, 1) Then
N = N + 1
If ws.Cells(i, 1) = Cells(1, 1) Then
buf = buf & ws.Cells(i, 4) & ","
End If
End If
Next i
Cells(k, j) = Cells(k, j) & M & "回(" & N & "," & Left(buf, Len(buf) - 1) & ")"
buf = ""
Next j
Next k
For k = 3 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To Cells(k, Columns.Count).End(xlToLeft).Column
Cells(k, 2) = Cells(k, 2) & WorksheetFunction.Substitute(Cells(k, j), "1回", "") & ","
Next j
Next k
For k = 3 To Cells(Rows.Count, 2).End(xlUp).Row
N = Len(Cells(k, 2)) - Len(WorksheetFunction.Substitute(Cells(k, 2), ",", ""))
Cells(k, 2) = WorksheetFunction.Substitute(Cells(k, 2), ",", "", N)
Next k
Columns(2).AutoFit
j = UsedRange.Columns.Count
Range(Columns(3), Columns(j)).Delete
Application.ScreenUpdating = True
End Sub 'この行まで

※　For～Nextを多少していますので、スマートでないかもしれません。
他に良い方法があればごめんなさいね。m(_ _)m

お礼

tom04さま

早速のご回答、ありがとうございます。
いただいた手順どおりに実行したところ、思い通りのデータが出力されたためたいへん感服しております。

まずはこういったことがVBAで可能であることがわかり、ほんとうにありがたく思っております。

今後はVBAを学んでいき、自分で一つ一つの要素が何を意味しどう構成されているのかを理解していき
突発的なエラーや要素の追加にも耐えうるように、またメンテナンスやちょっとした応用が自分でできるようになっていきたいと思います。

重ねがさね、ほんとうにありがとうございました。

回答No.2

mitarashi

#1さんの多重ループに敬服します。頭の体操にオブジェクト指向？でやってみましたが、「分からん」のは同様と思います。
もっと簡単な方法が無いとは言えませんが、いずれにせよメンテナンス困難なものになりそうなので、Accessのクエリでできる範囲のまとめ方で我慢されるのが、生産的と思います。

Sub test()
Dim personalData As Collection
Dim personalInfo As personalClass
Dim targetRange As range, myRow As range, destRange As range
Dim myName As String
Dim rankInfos(50) As Object
Dim i As Long, myRank As Long
Dim myKey As Variant, myKeys As Variant
Dim buf As String
Const lowestRank = 10 '任意に変更して下さい

Set personalData = New Collection
With ThisWorkbook.Worksheets(1)
Set targetRange = .range(.range("A2"), .range("A" & .Rows.count).End(xlUp)).Resize(, 4)
End With
Set destRange = ThisWorkbook.Worksheets(2).range("A3")
For Each myRow In targetRange.Rows
'累積の履歴を個人別にまとめる
myName = myRow.Cells(2).Value
On Error GoTo errHandle
Set personalInfo = personalData(myName)
personalInfo.add myRow.Cells(3).Value, myRow.Cells(4).Value
On Error GoTo 0
'今月の履歴を順位別にまとめる
If myRow.Cells(1).Value = ThisWorkbook.Worksheets(2).range("A1").Value Then
myRank = CLng(Replace(myRow.Cells(3).Value, "位", ""))
If rankInfos(myRank) Is Nothing Then
Set rankInfos(myRank) = CreateObject("Scripting.Dictionary")
End If
If Not rankInfos(myRank).exists(myRow.Cells(2).Value) Then
rankInfos(myRank).add myRow.Cells(2).Value, 1
Else
rankInfos(myRank)(myRow.Cells(2).Value) = rankInfos(myRank)(myRow.Cells(2).Value) + 1
End If
End If
Next myRow

For i = 1 To lowestRank
destRange.Value = CStr(i) & "位"
buf = ""
If Not rankInfos(i) Is Nothing Then
myKeys = rankInfos(i).keys
For Each myKey In myKeys
If rankInfos(i)(myKey) > 1 Then
buf = buf & myKey & rankInfos(i)(myKey) & "回"
Else
buf = buf & myKey
End If
buf = buf & personalData(myKey).history(CStr(i) & "位") & ","
Next myKey
destRange.Offset(0, 1).Value = Left(buf, Len(buf) - 1)
End If
Set destRange = destRange.Offset(1, 0)
Next i
Exit Sub
errHandle:
Set personalInfo = New personalClass
personalData.add personalInfo, myName
Resume Next
End Sub

'クラスモジュール personalClass
Dim myName As String
Dim rankCollection As Collection

Private Sub Class_Initialize()
Set rankCollection = New Collection
End Sub

Public Sub add(newStrRank As String, location As String)
Dim buf As Variant
Dim historyCls As historyClass

On Error GoTo newMenber
Set buf = rankCollection(newStrRank)
Set historyCls = rankCollection(newStrRank)
With historyCls
.add location
End With
Exit Sub
newMenber:
Set historyCls = New historyClass
rankCollection.add historyCls, newStrRank
Set historyCls = Nothing
Resume Next
End Sub

Public Property Get history(strrank As String) As String
Dim historyCls As historyClass

On Error GoTo errHandle
Set historyCls = rankCollection(strrank)
history = "(" & CStr(historyCls.count) & ", " & historyCls.location & ")"
Exit Property
errHandle:
history = ""
End Property

'クラスモジュール historyClass
Private myCount As Long
Private myLocation As String
Private myRank As String

Public Sub add(location As String)
If myLocation = "" Then
myLocation = location
myCount = 1
Else
myLocation = myLocation & ", " & location
myCount = myCount + 1
End If
End Sub

Public Property Get location() As String
location = myLocation
End Property

Public Property Get count() As Long
count = myCount
End Property

Public Property Let rank(newRank As String)
myRank = newRank
End Property

お礼

mitarashiさま
早速のご回答、ありがとうございます。

いただいたコードを実行しようとしたところ、
Public Sub add(location As String)のところでコンパイルエラー：名前が適切ではありません：addという
エラーメッセージに出会い、行き詰ってしまいました。

いただいた画像ではきっちりマクロが実行され、データが出力されているようでしたので
おそらく私の方で何かおかしな操作をしたか、設定がおかしいかではないかと思っております。

そういった意味でも、私が理解できていないものをいきなりそのまま利用することは
おっしゃるとおりメンテナンスが困難になるため危険ですので

どこがネックで戴いたコードを実行できないでいるのか、
自分で理解しそれを修正できるようになってから利用させていただきたいと思います。

私にとってはまずはVBAでこういった帳票が作成可能であるということを知っただけでも大収穫です。
今後は少しずつ、VBAを学んでいき、理解していければと思っております。

最後になりましたが、貴重なお時間を割いていただき
丁寧なご回答ほんとうにありがとうございました。