![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?5a7ff87)
エクセルについて質問です。
エクセルのバージョンは2007を使用しています。
下記sheet1のようなデータがあるときに、sheet2に月ごとに集計し
順位ごとにまとめてB列にまとめて記載する帳票を作っているのですが
(※ちなみにその形式を説明させていただきますと
該当者がいなければB列には空白を返し
該当者がいる場合はB列に個人ごとにまとめ、
(1)名前、(2)その月にその人がその順位をとった回数《1度のみの時は省略》、そして
括弧の中に(3)4月から積み重ねてその人がその順位をとった回数、(4)その時の場所 を記載し
すべて半コンマ(,)プラス空白で区切ってB列の1セル内に羅列しております)
これをsheet1にデータを入力すれば自動的にsheet2のB列に
今の形式で反映されるようにしたいのです。
エクセルの関数でできるならばもちろんその方法を知りたいのですが
もし不可能であるならばVBA?マクロ?なども勉強して組んでいければと思っています。
今はどのプログラムを使えば自動化できるのかについても理解しておりませんので
どのプログラムをどんなふうに学んでいけばいいのかさえ見当がつかずじまいの状態です。
これを使ってこうすればできるよ、という方法をご存知の方がいらっしゃいましたら
そのさわりの部分、ヒントだけでもかまいませんので教えていただきたいのです。
どうかよろしくお願いいたします。
<sheet1>
A B C
1 月 名前 成績 場所
2 4月 山田 1位 甲
3 4月 佐藤 2位 乙
4 5月 佐藤 2位 甲
5 5月 佐藤 2位 甲
6 5月 山田 3位 丙
7 5月 佐藤 4位 丁
8 5月 山田 2位 甲
<sheet2>
A B
1 5月度成績
2
3 1位 空白
4 2位 佐藤2回(3, 甲, 甲), 山田(1, 甲)
5 3位 山田(1, 丙)
6 4位 佐藤(1, 丁)
No.1ベストアンサー
- 回答日時:
こんばんは!
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
- 回答日時:
#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
![「エクセル DBから該当データを抜き出し帳」の回答画像2](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/e/1359307_5497e57658210/M.jpg)
mitarashiさま
早速のご回答、ありがとうございます。
いただいたコードを実行しようとしたところ、
Public Sub add(location As String)のところでコンパイルエラー:名前が適切ではありません:addという
エラーメッセージに出会い、行き詰ってしまいました。
いただいた画像ではきっちりマクロが実行され、データが出力されているようでしたので
おそらく私の方で何かおかしな操作をしたか、設定がおかしいかではないかと思っております。
そういった意味でも、私が理解できていないものをいきなりそのまま利用することは
おっしゃるとおりメンテナンスが困難になるため危険ですので
どこがネックで戴いたコードを実行できないでいるのか、
自分で理解しそれを修正できるようになってから利用させていただきたいと思います。
私にとってはまずはVBAでこういった帳票が作成可能であるということを知っただけでも大収穫です。
今後は少しずつ、VBAを学んでいき、理解していければと思っております。
最後になりましたが、貴重なお時間を割いていただき
丁寧なご回答ほんとうにありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) EXCEL 関数を教えてください。(A列の同じ値が複数ある場合vlookupで出来ますか) 4 2022/12/07 20:54
- Excel(エクセル) Excelについて 4 2023/03/02 09:24
- 野球 夏の甲子園出場回数ランキング 大分 1 2022/12/19 07:34
- その他(プログラミング・Web制作) Python pandasについての質問です。 日付 名前 ◯月◯日 佐藤 ・ 伊藤 ・ 山田 ・ 2 2022/06/13 17:16
- Visual Basic(VBA) 指定月分の顧客データファイルを統合して並べ替え、所定の場所に貼り付ける (再質問) 4 2022/09/14 22:51
- Excel(エクセル) エクセルの条件付き書式 個人シートを参照して集計シートに色付けしたい 1 2023/06/22 00:39
- Visual Basic(VBA) 指定月分の顧客データファイルを統合して並べ替え、所定の場所に貼り付ける 3 2022/09/10 07:55
- Excel(エクセル) 至急です><Excelの関数を教えてください。 2 2022/03/22 17:56
- Excel(エクセル) 非表示にしたい行をグループ化して折り畳み 4 2022/09/17 20:17
- 統計学 投票のジレンマ。 3 2023/05/13 22:16
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルで印刷をするときのマ...
-
【ExcelVBA】sheet作成時にマク...
-
不明なコマンドです("FROM")。...
-
Chromebook Linux Extundelete...
-
Access2010 「演算子がありませ...
-
エクセル/マクロ Exit Subが実...
-
オペランドが足りませんとコメ...
-
mfc42.dllファイルってなんです...
-
困ってます。
-
Vista RC1のインストールが上手...
-
VBAで横データを縦データに変換...
-
マクロ実行ボタンがコピー出来ない
-
3つのOSをマルチブートしたい
-
MFT(マスターファイルテーブル)...
-
パソコンのブルースクリーンエ...
-
Excelマクロによる単語リストの...
-
Cuda check failed(35 vs 0):CU...
-
シート保護でオートフィルタ機...
-
GhostからWin XPがインストール...
-
eclipse,phonegapでandroid
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセル DBから該当データを...
-
不明なコマンドです("FROM")。...
-
Access2010 「演算子がありませ...
-
オペランドが足りませんとコメ...
-
【ExcelVBA】sheet作成時にマク...
-
エクセル/マクロ Exit Subが実...
-
mfc42.dllファイルってなんです...
-
VBA シートの切り替えができな...
-
エクセルの文字間スペースを入...
-
貼り付けをマクロで禁止させたい。
-
(int)キャストとintvalの違い
-
pythonでrequestsが使えない
-
エクセル 「実行時エラー"13":...
-
Excel2010でふりがなが漢字にな...
-
Access2007 DoCmd.ApplyFilter...
-
VBAで横データを縦データに変換...
-
AUTOCAD 2010でdwlファイルの場...
-
エクセル 複数シートのフィル...
-
『PHP』 MAMPで$_SERVER["REMOT...
-
マクロ実行ボタンがコピー出来ない
おすすめ情報