条件分岐、文字検索を同時に行うコード

質問

.エクセルＶＢＡの条件分岐に関するコードに関して、
質問させていただきます。

シート１にある表（画像をご参照ください）に
おいて条件に合う方の行に入っている
「ＡＭ」「ＰＭ」という文字を
「出席」という文字に置き換えたいのです。

置き換える場所は、
別シート（画像：シート2）になります。

―――皆様にご教授いただきたいのは――――

【１】
シート１「顧客簿」において、
見学の列が「○」かつ退会の列が「（空欄）」である
ものを探すコードの書き方

【２】
シート２「カレンダー」において
上記【１】に該当する方が
いらっしゃる曜日を探すコード

例）シート１の佐藤さんは「見学が○かつ退会が空欄」
↓↓↓↓↓
佐藤さんは条件に合致
↓↓↓↓↓
佐藤さんは月曜と水曜に通っている
↓↓↓↓↓
シート２の月曜を探す
↓↓↓↓↓
シート２の佐藤さんの行の月曜の列に入っている
「ＡＭ」を「出席」に置き換え
↓↓↓↓↓
シート２の佐藤さんの行の水曜の列に入っている
「ＰＭ」を「出席」に置き換え

※※※※
シート２「カレンダー」の日付、曜日のセルには
date 関数を使用しており、
自動で月ごとに表示される使用です。
※※※※

【２】
また、300人以上のデータがある場合、
どのようにコードを書けば、
繰り返し条件を探す【１】の処理を実行することが
可能でしょうか？

【１】と【２】を実現する
コードをお教え願いたく存じます。

――――――――――――――――――
ＶＢＡ初心者で質問の仕方も
適切な表現でなく、誠に申し訳ございません。

よろしくお願い申し上げます。

回答No.3

tom04

No.1です。

＞コードの下から９行目にある
＞「End If」の部分で
＞エラー表示が出てしまい、
＞動きません。

すなわち
＞If wS.Cells(3, k) <> "" Then
＞wS.Cells(c.Row, k) = "出席"
の部分でのエラーだと思われます。

一番怪しいのは「小の月」の場合など31日のセルが空白になっていない。
という原因が考えられます。
前回Sheet2の4行目・5行目の数式を投稿したのは
大の月・小の月に対応するためのものです。
今一度4行目の数式を見直して、
（1）シリアル値になっているか？
（2）小の月の月末部分が空白になっているかどうか確認してみてください。
（5行目は今回利用していませんので、気にしなくて大丈夫です）

今考えられる原因としてはこの程度ですが・・・
これでもダメなら、
列方向の「日付」「曜日」のセルにはどんな数式を入れているか教えてください。
（お手元のExcelのレイアウトも判ればより的確なアドバイスができると思います）
それに基づいて、もう一度他の方法を考えてみます。m(_ _)m

回答No.2

eden3616

Alt+F11でVBEを開き、挿入から標準モジュールを挿入して下記のVBAコードを貼り付けてください。
VBEを閉じてからAlt+F8または表示→マクロより「Action」を選び実行してください。

シート名を「顧客簿」と「カレンダー」であるとして作成しています。
異なる場合はコード内の以下の箇所を変更してください。
　　'シート名の設定
　　Set mySt(0) = Sheets("顧客簿")
　　Set mySt(1) = Sheets("カレンダー")

>また、300人以上のデータがある場合、どのようにコードを書けば、
>繰り返し条件を探す【１】の処理を実行することが可能でしょうか？

該当の表が下に同じ様式で連なっているのであれば、
表を増やすことで対応できます。（添付画像参照）
ただし、同姓同名である場合はどう処理するのでしょうか？
現在のコードでは名前は重複しないものとして作成しています。

■VBAコード

Sub Action()
'型宣言
Dim mySt(1) As Worksheet
Dim i As Long
Dim j As Integer
Dim myTar As Range
Dim bkRng As Range
Dim nxRng As Range

'シート名の設定
Set mySt(0) = Sheets("顧客簿")
Set mySt(1) = Sheets("カレンダー")

'実処理
With mySt(0)
　　'2行目～A列の最終行まで繰り返し処理
　　For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
　　　　'【1】対象行iの列Bが○で列Cが空欄の場合の処理
　　　　If .Range("B" & i) = "○" And Len(.Range("C" & i)) = 0 Then
　　　　　　'カレンダーシートの名前を検索
　　　　　　Set myTar = mySt(1).Columns("A").Find(.Range("A" & i))
　　　　　　'4列目（D）～8列目（H）まで繰り返し処理
　　　　　　For j = 4 To 8
　　　　　　　　'対象のセルが空白でなければ（AM、PMが入っていれば）処理
　　　　　　　　If Len(.Cells(i, j)) > 0 Then
　　　　　　　　　　'ユーザー定義関数で処理し、返ったセルに出席を入力
　　　　　　　　　　mySearch(mySt(1), 2, myTar.Row, .Cells(1, j)) = "出席"
　　　　　　　　End If
　　　　　　Next j
　　　　End If
　　Next i
End With
End Sub
'行方向に検索して一致したオフセットセルを返すユーザー定義関数
Function mySearch(mySt As Worksheet, srow As Long, trow As Long, word As String) As Range
Dim hit As Long
On Error GoTo era
With mySt
Do
　　hit = WorksheetFunction.Match(word, .Range(.Cells(srow, hit + 1), .Cells(srow, Columns.Count)), 0) + hit
　　If mySearch Is Nothing Then
　　　　Set mySearch = .Cells(trow, hit)
　　Else
　　　　Set mySearch = Union(mySearch, .Cells(trow, hit))
　　End If
Loop
End With
Exit Function
era:
End Function

回答No.1

tom04

こんばんは！
一例です。

↓の画像で上側が元データのSheet1・下側がSheet2とします。
Sheet2の3行目は作業用の列として使用していますので、画像通りの配置にしてみてください。

＞シート２「カレンダー」の日付、曜日のセルには
＞date 関数を使用しており、
とありますが
画像ではSheet2のB4セル（セルの表示形式はユーザー定義から　d　としています）に
=IF(MONTH(DATE($A1,$A2,COLUMN(A1)))=$A2,DATE($A1,$A2,COLUMN(A1)),"")

B5セル（セルの表示形式はユーザー定義から aaa　としています）に
=IF(B4="","",B4)

という数式を入れB4・B5セルを範囲指定　→　B5セルのフィルハンドルで月末（31日）までのAF列までコピーしています。
（この数式でSheet2のA1・A2セルの数値を入れ替えるだけで自動で日付・曜日が変わります）

以上の下準備ができた上でのVBAでの一例です。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, lastRow As Long
Dim c As Range, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")

lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS.Cells(4, "B"), wS.Cells(4, "AF")).Copy wS.Range("B3")
With Range(wS.Cells(3, "B"), wS.Cells(3, "AF"))
.Formula = "=TEXT(B4,""aaa"")"
.Value = .Value
End With
Range(wS.Cells(6, "B"), wS.Cells(lastRow, "AF")).ClearContents
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "B") = "○" And .Cells(i, "C") = "" Then
For j = 4 To .Cells(1, Columns.Count).End(xlToLeft).Column
If .Cells(i, j) <> "" Then
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Set r = wS.Rows(3).Find(what:=.Cells(1, j), LookIn:=xlValues, lookat:=xlWhole)
For k = r.Column To 32 Step 7
If wS.Cells(3, k) <> "" Then
wS.Cells(c.Row, k) = "出席"
End If
Next k
End If
Next j
End If
Next i
End With
wS.Rows(3).Clear
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

補足

早々の返信、
誠にありがとうございます。

ただ、

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
コードの下から９行目にある
「End If」の部分で
エラー表示が出てしまい、
動きません。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

解決策、あるいは他の策を
お教え願いますでしょうか？

どうかよろしくお願い申し上げます。