ここから本文です

エクセルマクロについて イベント参加者の合計をシートに一覧で表示したいです...

アバター

ID非公開さん

2018/7/1017:07:28

エクセルマクロについて

イベント参加者の合計をシートに一覧で表示したいです。

sheet1にはB列に参加者名、C列に参加日を入力しています。

画像の様にsheet2には
2018年7月と、手入力すると日付(B列)・曜日(C列)が変わる簡単なカレンダーにしています。

sheet2の集計ボタンを作って、ボタンをクリックすれば
7月中の参加者が5行目D列から右隣に参加者が並び
参加日に「〇」が付く一覧表を作りたいのですが、VBAに知識がなくお願い致します。
又各月に対応したいので集計ボタンではなく、月にあたる「B3」のセルを変更した場合でも構いません。よろしくお願い致します。

Sheet2,Sheet1,Next dataElm,集計ボタン,Then Exit For,参加者名,Next memberElm

閲覧数:
33
回答数:
1
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

tam********さん

編集あり2018/7/1111:47:02

こんばんは

次のようなコードはいかがでしょうか。

Sub Test()

__Dim dataSheet As Worksheet 'データがあるシート
__ Set dataSheet = Worksheets("Sheet1")
__Dim dataRng As Range 'データのある範囲
__ Set dataRng = dataSheet.Range("B1:B30") '仮の範囲です
__Dim dataElm As Range 'データ走査用
__
__Dim calendarSheet As Worksheet 'カレンダーがあるシート
__ Set calendarSheet = Worksheets("Sheet2")
__Dim memberRng As Range 'メンバーの範囲
__ Set memberRng = calendarSheet.Range("C5:Z5") '仮の範囲です
__Dim memberElm As Range 'メンバー走査用
__
__For Each dataElm In dataRng 'データ範囲の走査
__
____If dataElm.Value = "" Then Exit For 'データが空白になれば終了(データ範囲が空白を挟まない前提)
____
____For Each memberElm In memberRng 'カレンダーシートのメンバー範囲を走査
____
______If dataElm.Offset(0, 1).Value = memberElm.Value Then '日付の右隣(氏名)がメンバーに一致したら
________memberElm.Offset(dataElm.Value + 1, 0).Value = "○" 'メンバーから下に日数分+1ずらした所に○を記入
______End If
______
____Next memberElm
____
__Next dataElm

End Sub
※アンダースコア「__」を半角スペース「 」に置換してお使いください。

・データ部分の日付は、日のみを入れていると仮定してあります。これを利用して、カレンダーシートのメンバー名から日数分ずらした所に、○を入れる流れです

・データの範囲とカレンダーのメンバー範囲は、仮のものを入れています

・「メンバーから下に日数分+1」と「+1」してあるのは、日付と曜日の見出し行の分、余分にずらしてあげる必要があるからです

日付が月日や年月日などの場合は、日のみを取り出すなどの工夫が必要ですが、基本的な処理の流れとしては同じです。

後は、このようなコードを適当なボタンに登録して用いれば良いかと思います。

↓↓↓ここから改良コード
Sub Test()
__'データシート関連
__Dim dataSheet As Worksheet 'データがあるシート
__ Set dataSheet = Worksheets("Sheet1")
__Dim dataRng As Range 'データのある範囲
__ Set dataRng = dataSheet.Range("B:B") '仮の範囲です
__Dim dataElm As Range 'データ走査用
__
__'カレンダーシート関連
__Dim calendarSheet As Worksheet 'カレンダーがあるシート
__ Set calendarSheet = Worksheets("Sheet2")
__Dim yearRng As Range '年セル
__ Set yearRng = calendarSheet.Range("B2")
__Dim monthRng As Range '月セル
__ Set monthRng = calendarSheet.Range("B3")
____
__Dim memberDic As Object '名簿用辞書
__ Set memberDic = CreateObject("Scripting.Dictionary")
__
__'名簿辞書作成
__For Each dataElm In dataRng 'データ範囲の走査
__
____If dataElm.Value = "" Then Exit For 'データが空白になれば終了(データ範囲が空白を挟まない前提)
____
____If Not memberDic.Exists(dataElm.Offset(0, 1).Value) Then 'データ(日付)右隣の氏名を辞書に追加
______memberDic.Add dataElm.Offset(0, 1).Value, 0
____End If
____
__Next dataElm
__
__'名簿作成
__Dim memberStartRng As Range '名簿開始セル
__ Set memberStartRng = calendarSheet.Range("D5")
__Dim memberRng As Range '名簿の範囲
__ Set memberRng = calendarSheet.Range(memberStartRng, memberStartRng.Offset(0, memberDic.Count - 1)) '開始セル+名簿の人数分
__
__Dim joinCheckRng As Range '参加チェック範囲
__ Set joinCheckRng = calendarSheet.Range("D5:AE100") '広めに取ってあります
__joinCheckRng.ClearContents 'チェック範囲の内容を削除
__
__memberRng.Value = memberDic.Keys '名簿範囲に名簿辞書のキーを転記
__
__Dim memberElm As Range '名簿走査用
__Dim nameRng As Range '名前セル
__
__For Each dataElm In dataRng 'データ範囲の走査
__
____If dataElm.Value = "" Then Exit For 'データが空白になれば終了(データ範囲が空白を挟まない前提)
____
____Set nameRng = dataElm.Offset(0, 1) 'データ(日付)セルの右隣を名前セルとして取得
____
____For Each memberElm In memberRng 'カレンダーシートのメンバー範囲を走査
________'↓カレンダーの年月と合い、かつ日付の右隣(氏名)がメンバーに一致したら
______If Year(dataElm.Value) = yearRng.Value And Month(dataElm.Value) = monthRng.Value And nameRng.Value = memberElm.Value Then
________memberElm.Offset(Day(dataElm.Value) + 1, 0).Value = "○" 'メンバーから下に日数分+1ずらした所に○を記入
______End If
______
____Next memberElm
____
__Next dataElm

End Sub

  • アバター

    質問者

    ID非公開さん

    2018/7/1109:55:13

    説明も付けて下さりありがとうございます。
    シート名、アンダーバーを空白にて試させて頂いたのですが、〇印がつかない状態です。
    こちらの説明不足で申し訳ありませんが、画像のAさんCさんなどは空白の状態で、7月に参加された方のみ名前が入力される。
    そんな形にしたいのですが、ちょっと違うようなので申し訳ありませんがお願いします。

  • その他の返信(3件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

アバター

質問した人からのコメント

2018/7/11 12:46:04

完璧です!素晴らしいご対応本当にありがとうございました!

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる