vlookupを使ったマクロの書き方

質問

マクロ中で、VLOOKUPを使用して、下記②のExcelファイルの職員番号と、下記①の職員番号が一致していて、①のD列にメールアドレスが入ってない場合のみ、②のファイルのメールアドレスを、①のD列へ挿入したいのですが、マクロの書き方がわかりません、何方かご教示頂けましたら、大変助かります。

①ファイル名＝F:\11_データ\課題参画者リストまとめ\2024参画者リストまとめ_20240311.xlsx
　シート名＝参画者リスト
　職員番号＝B列2行目以降
　メールアドレス＝D列の2行目以降
　シートのA列～H列に値が入っていますが、メールアドレスのセルは、記載無し、記載有りのセルがあります。

②ファイル名＝F:\12_データ\課題参画者リストまとめ\職員マスタ.xlsx
　シート名＝職員マスタ420227
　職員番号＝A列2行目以降
　メールアドレス＝C列2行目以降
　シートのA列～C列は値が入っています。

※①のファイルは、データ連結マクロで複数のファイルを纏めたExcelファイルになります。
　タイムスケジューラで自動で起動させる為、vbsファイル中に、マクロファイルを設定させて、
　バッチファイルでこのvbsファイルを起動して作成しております。

2024年度-参画者リスト作成.vbsの中身は以下の通りで、このファイルをバッチファイルに設定して使っております。
Dim WB_PATH
Const PROC_NAME = "参画者リストおまとめ"

Dim excelApp
Set excelApp = CreateObject("Excel.Application")

WB_PATH = "C:\Users\watan\Documents\27_EXCEL教習\TEST\11_2024-課題参画者リスト\スクリプト\【自動起動】課題参画者リストまとめシートv4.xlsm"

With excelApp
.Visible = False
Dim wb
Set wb = .Workbooks.Open(WB_PATH)
.Run "'" & wb.Name & "'!" & PROC_NAME
.DisplayAlerts = False
wb.Save
wb.Close
End With

excelApp.Quit
Set excelApp= Nothing

回答No.8

HohoPapa · ベストアンサー

お話しされている挙動からの推測となりますが、
今回のマクロが終了しきれていないものと思います。

vbsでの経験がないので、シャープなコメントは困難です。
私だったら、先に、
https://okwave.jp/qa/q10237306/a28380485.html
で案内しました
https://website-note.net/windows/how-to-open-an-excel-file-from-task/
の機能で実装してみます。
この機能での実装経験ならいくつもありますし、
課題のトラブルになったことはありません。

おそらく、
Private Sub Workbook_Open()
'今回のマクロ
End Sub
といった記述になっているものと思いますが、
この終盤で自身を終了するようにコードを追加するわけですが、
どのように記述するのか、さらに、
組み込むと起動後勝手に終わってしまうので、
ＶＢＡのメンテナンスのチャンスを失う課題もあります。

この辺りの話は、新たな話題になりますので
このスレッドをクローズし
新たなスレッド立ててほしいです。

そうすれば、
もっと別な、より識者の方の支援を受けることができるだろうと思います。
（私も非力ながら参加させてもらうかも知れませんが）

お礼

本日、タイムスケジューラー上で再設定し、マクロの正常稼働を確認しました。また、ログファイルも上書きモードで設定し、正常に作成された事を確認しました。
本当に色々とご教示を頂きまして、誠に有難うございました。

補足

早速の有難いご教示ありがとうございました。
バッチファイルを起動した時のエラーメッセージを確認した所、VBSファイル起動時、下記コードで認識出来ない旨のメッセージが出ている事がわかりました。
　Const PROC_NAME = "UpdateEmailAddressesWithLog"

以下のようにへ変更し、ExcelのマクロはVBSファイルで正常に起動する事が出来ました。　　　　
　Const PROC_NAME = "Mainjob"　←Excelのマクロ名を入れる

直ぐに、根を上げてお騒がせしてしまいまして申し訳ありませんでした。
タイムスケジューラに設定し、無事正常稼働する事が出来ましたので、ご報告致します。
ログファイルについては、ご教示頂きました事を月曜日に実施し、その結果をご報告してから、今回のご質問は閉じさせて頂きたいと思っております。
色々と親身にご教示頂きまして、本当に有難うございました。

回答No.7

HohoPapa

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMMDDHHNNSS") & "MentLog.csv"
以上のコードを直すと、以下のバリエーションになります。

日ごとに１つのファイルにする場合

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMMDD") & "MentLog.csv"

月ごとに１つのファイルにする場合

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMM") & "MentLog.csv"

１つのファイルに止めどなく追記し続ける場合

LogFile = ThisWorkbook.Path & "\" & _
"MentLog.csv"

１つのファイルに常に新規作成（処理の都度上書き）する場合

LogFile = ThisWorkbook.Path & "\" & _
"MentLog.csv"
Open LogFile For Output As #2
Close #2

以下、加えて、仕様上の制限を書きます。

SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf

このコードから推測できるかもしれませんが
職員DBファイルは最大50000行です。
また、
[メールアドレス]、[nimsID]の列は、
Ａ列以降、Ｚ列までの間に配置する必要があります。

SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
を
SQL = SQL & "FROM [" & TblSheet & "$A1:F500]" & vbCrLf

といったようにコンパクトにすることも可能ですが
コンパクトにしても、おそらく、
処理スピードが体感できるほど改善することはありません。

補足

ログファイルやデータの設定についてのご教示ありがとうございます。

本日、マクロファイルをバッチファイルで起動させた所、参画者リストへのメールアドレスの追記は正常に出来たようですが、ログファイルが作成されず、マクロファイルも再び開こうとすると、『編集のためロックされています』のメッセージが出て、読み取り専用になってしまいました。

因みに、マクロファイル内で直接マクロを実施した時は、ログファイルは正常に作成されて、マクロファイルも正常に終了します。

VBSファイル、またはバッチファイルの何れか影響しているようです。
もう一歩と言う所なのですが、なかなか難しいものです。
大変大変、恐縮なのですが、もし対処方法をお気づきのようでしたら、ご教示頂けると大変助かります。
下記はVBSファイルの記載になります。
Dim WB_PATH
Const PROC_NAME = "UpdateEmailAddressesWithLog"

Dim excelApp
Set excelApp = CreateObject("Excel.Application")

WB_PATH = "C:\Users\watan\Documents\スクリプト\メールアド挿入マクロ-ログファイル有り【メールアド記載有りはそのまま】-2.xlsm"

With excelApp
.Visible = False
Dim wb
Set wb = .Workbooks.Open(WB_PATH)
.Run "'" & wb.Name & "'!" & PROC_NAME
.DisplayAlerts = False
wb.Save
wb.Close
End With

excelApp.Quit
Set excelApp= Nothing

回答No.6

HohoPapa

>『20240311』を現在の日時(20240319)に変更

>既に記載しているメールアドレスを比較し、
> 記載が違っていたら、ログファイルにその情報を書き込む

それぞれ対応してみました。
なお
当初の想定よりも多くのＩＦ文を使うコードとなり、
相当書き換えましたので
十分なテスト、評価をゼロベースで行ってください。

Option Explicit

Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員DB.xlsx"
Const TblSheet = "職員DB"
Const NumCol = 2 '転記先職員番号列番号
Const AddressCol = 4 '転記先メールアドレス列番号
Dim LogFile As String
Dim tgBookName As String

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMMDDHHNNSS") & "MentLog.csv"
Logput "M0", "", "", "", "転記処理開始"

'対象ファイル名の組立
tgBookName = _
"D:\TestDir\" & _
Format(Now, "YYYY") & _
"参画者リストまとめ_" & _
Format(Now, "YYYYMMDD") & _
".xlsx"

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 1
With tgBook.Sheets(tgSheet)
Do
r = r + 1
If .Cells(r, NumCol).Value = "" Then Exit Do

If IsNumeric(.Cells(r, NumCol).Value) = False Then
Logput "M2", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "職員番号が不正"
Else
HitAddress = GetMailAdress(.Cells(r, NumCol).Value)

If HitAddress = "Not Found" Then
Logput "M3", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "職員番号が見つからない"

ElseIf ((HitAddress = "Null") Or (HitAddress = "")) Then
Logput "M4", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "マスターのメールアドレスが空欄"

ElseIf .Cells(r, AddressCol).Value <> "" Then
If HitAddress <> .Cells(r, AddressCol).Value Then
Logput "M5", Format(r, "0"), _
.Cells(r, NumCol).Value, .Cells(r, AddressCol).Value, "既に異なるアドレスが埋まっている" & "," & HitAddress
Else
Logput "M6", Format(r, "0"), _
.Cells(r, NumCol).Value, .Cells(r, AddressCol).Value, "既に同じアドレスが埋まっている"
End If

Else
.Cells(r, AddressCol).Value = HitAddress
Logput "M1", Format(r, "0"), _
.Cells(r, NumCol).Value, HitAddress, "メールアドレスをセット"
End If
End If
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close
Logput "M9", "", "", "", "転記処理終了"

End Sub

以下、

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As Long) As String

と

'//ログ出力ルーチン
Sub Logput(MsgCode As String, _

は、前回ポストしたものと変更が無いので、
今回はポストしていません。

補足

早速、希望した項目に対応下さいまして、誠に有難うございました。
早速、マクロを実行した所、正常に稼働出来、又ログファイルも正常に作成された事を確認しました。
ログファイルでメールアドレスの記載状況が一目で分かり、大変効率が良くなりそうです。
メールアドレスの記載状態の項目もこれで完璧です。
明日以降で、タイムスケジューラでマクロを実行し、結果をご報告させて頂きます。

職員DBファイルは2週間毎に更新しますが、課題毎のファイルの連結マクロと、今回作成頂いたマクロはタイムスケジューラで1日に5回実行します。
ログファイルが1日5個作成される事になるので、やはりログファイルは上書きコピーするか、削除した方が良いかなと考えております。
大変お手数なのですが、ログファイルの上書き又は、削除をするマクロについても、ご教示頂けましたら大変助かります。

ログファイルを残す今回のマクロも、このルーチン作業で問題が生じた時は必要と思いますので、その時は使わせて頂きます。

回答No.5

HohoPapa

>職員DBに職員番号は存在するが、
>メールアドレスの欄が空白の時にこのエラーが出ているようです
エラーにならないようにしてみました。
また、その旨ログが残るようにし
合わせて、ログのフォーマットを以下のように再考しました。
実行日時、メッセージコード、
　　転記先行番号、職員番号、メールアドレス、
　　メッセージテキスト

Option Explicit

Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員DB.xlsx"
Const TblSheet = "職員DB"
Const NumCol = 2 '転記先職員番号列番号
Const AddressCol = 4 '転記先メールアドレス列番号
Dim LogFile As String

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMMDDHHNNSS") & "MentLog.csv"
Logput "M0", "", "", "", "転記処理開始"

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 2
With tgBook.Sheets(tgSheet)
Do
If .Cells(r, NumCol).Value = "" Then Exit Do

If IsNumeric(.Cells(r, NumCol).Value) = False Then
Logput "M2", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "職員番号が不正"
ElseIf .Cells(r, AddressCol).Value <> "" Then
Logput "M3", Format(r, "0"), _
.Cells(r, NumCol).Value, .Cells(r, AddressCol).Value, "既にアドレスが埋まっている"
Else
HitAddress = GetMailAdress(.Cells(r, NumCol).Value)
If HitAddress = "Not Found" Then
Logput "M2", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "職員番号が見つからない"
ElseIf ((HitAddress = "Null") Or _
(HitAddress = "")) Then
Logput "M4", Format(r, "0"), _
.Cells(r, NumCol).Value, "", "マスターのメールアドレスが空欄"
Else
.Cells(r, AddressCol).Value = HitAddress
Logput "M1", Format(r, "0"), _
.Cells(r, NumCol).Value, HitAddress, "メールアドレスをセット"
End If
End If
r = r + 1
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close
Logput "M9", "", "", "", "転記処理終了"

End Sub

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As Long) As String

Dim SQL As String
Dim cn As Object
Dim rs As Object

'SQL文の実行準備
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open TblBook

'SQL文の組立
SQL = ""
SQL = SQL & "select [メールアドレス]" & vbCrLf
SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [nimsID] = " & sNum & vbCrLf

rs.Open SQL, cn

'ヒットする行が無かったら抜ける
If rs.EOF = True Then
GetMailAdress = "Not Found"
Exit Function
Else
If IsNull(rs("メールアドレス")) Then
GetMailAdress = "Null"
Else
GetMailAdress = rs("メールアドレス")
End If
End If

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

'//ログ出力ルーチン
Sub Logput(MsgCode As String, _
LineNum As String, _
sNum As String, _
address As String, _
MsgText As String)

Dim LineData As String
LineData = Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & _
MsgCode & "," & _
LineNum & "," & _
sNum & "," & _
address & "," & _
MsgText
Open LogFile For Append As #2
Print #2, LineData
Close #2
End Sub

補足

早速、マクロを修正頂きましてありがとうございました。マクロは正常に動きました。
メールアドレス追加状況のログファイルを確認しまして、大変見やすく関心致しました。

日々お忙しい中大変恐縮なのですが、2つ程、お願いがございます。もし、可能でしたら、ご教示頂けましたら幸いです。

①下記コードですが、『20240311』を現在の日時(20240319)に変更して頂く事は可能でしょうか？
　Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
　※連結ファイルの2024参画者リストまとめ_20240311.xlsxは、タイムスケジューラで実行する毎に、実行日時の名前が入ったファイル名で作成されます。
　※コードを色々といじってみたのですが、未熟な知識な為、修正する事が出来ませんでした。

②メールアドレスを追加する条件はそのままで、
　職員DBのメールアドレスと2024参画者リストまとめ_20240311.xlsxに既に記載しているメールアドレスを比較し、記載が違っていたら、ログファイルにその情報を書き込む事は可能でしょうか？
　※既に記載されている、2024参画者リストまとめ_20240311.xlsx中メールアドレスは手動で打ち込んでいる為、記載ミスが発生する可能性があります。
既に記載されている2024参画者リストまとめ_20240311.xlsxのメールアドレスは上書きせず、ログファイルで職員DBとの違いを確認したいです。

回答No.4

HohoPapa

>②のファイル名、シート名、タイトル名が今後変更になりそうなのですが、
>ご教示頂いたマクロの何処を修正すれば良いのか分かりませんでした。
職員DB側はSQL文でアクセスする関係で、列番号の概念はありません。
列タイトル（1行目の列名）でアクセスします。
SQL文に記述される名前と1行目の列名を合わせてください。
フルパス、シート名は定数に埋めています。

>①のファイルについても、変更があるかもです。
この部分はごく一般的なコードですの想像できると思いましたが
定数として宣言するようにしました。

>職員DB.xlsxに記載されているメールアドレスは、無記入の行が度々ありましたが
職員番号を使いアクセスしていますので、
ゴミレコードがあっても悪さはしません。

まずは、
>お薦めの『YYYYMMDDHHMM_メール抽出.log』を希望します
で書いてみました。
これで期待通りなら、
その後、
>マクロ起動前にログファイルを削除し、再作製するやり方
をポストします。
何度もやり取りしたくないからです。

当方、昼間は本業に追われ、このサイトでやり取りできるのは
夜か、休日です。
つまり、タイムリーには返答できませんので
この点を理解してもらうか、別な識者のコメントを待ってください。

Option Explicit

Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員DB.xlsx"
Const TblSheet = "職員DB"
Const NumCol = 2 '転記先職員番号列番号
Const AddressCol = 4 '転記先メールアドレス列番号
Dim LogFile As String

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

LogFile = ThisWorkbook.Path & "\" & _
Format(Now, "YYYYMMDDHHNNSS") & "MentLog.csv"

Logput "M0", "転記処理開始"

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 2
With tgBook.Sheets(tgSheet)
Do
If .Cells(r, NumCol).Value = "" Then Exit Do

If IsNumeric(.Cells(r, NumCol).Value) = False Then
Logput "M4", r & "行目は職員番号ではない"
ElseIf .Cells(r, AddressCol).Value <> "" Then
Logput "M3", r & "行目には既にアドレスが埋まっている"
Else
HitAddress = GetMailAdress(.Cells(r, NumCol).Value)
If HitAddress <> "Not Found" Then
.Cells(r, AddressCol).Value = HitAddress
Logput "M1", r & "行目に" & HitAddress & "をセット"
Else
Logput "M2", "職員番号:" & .Cells(r, NumCol).Value & "がマスターにいない"
End If
End If
r = r + 1
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close

Logput "M9", "転記処理終了"

End Sub

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As Long) As String

Dim SQL As String
Dim cn As Object
Dim rs As Object

'SQL文の実行準備
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open TblBook

'SQL文の組立
SQL = ""
SQL = SQL & "select [メールアドレス]" & vbCrLf
SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [nimsID] = " & sNum & vbCrLf

rs.Open SQL, cn

'ヒットする行が無かったら抜ける
If rs.EOF = True Then
GetMailAdress = "Not Found"
Exit Function
Else
GetMailAdress = rs("メールアドレス")
End If

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

'//ログ出力ルーチン
Sub Logput(MsgCode As String, MsgText As String)
Dim LineData As String
LineData = Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & MsgCode & "," & MsgText
Open LogFile For Append As #2
Print #2, LineData
Close #2
End Sub

補足

早速のマクロの修正をして頂きまして、大変恐縮です。
お忙しい中、もうしわけありませんでした。

・タイトル行については、①も②の同じに記載にして、修正マクロを起動してみました。

・下記のコードで、『Nullの使い方が不正です。』のエラーが出て、マクロが止まりました。
GetMailAdress = rs("メールアドレス")

職員DBに職員番号の記載が無い時は、エラーが出ず、
恐らく、職員DBに職員番号は存在するが、メールアドレスの欄が空白の時にこのエラーが出ているようです。
※このエラーが出た時点で、①ファイルへのメールアドレス追記も止まっています。

お手数の時にでも、対処方法をご教示頂けましたら幸いです。

回答No.3

HohoPapa

>①ファイルのB列は、通常は数値として認識し抽出するが、
>メッセージ的な値が入っている行は無視するようにしたいのです
数字以外が含まれていたら、その行は無視する。
というコードとしてみました。いかがでしょうか。

>このマクロはタイムスケジューラーで自動起動させますので、
>マクロ開始、終了時刻と
>メールアドレス抽出状態をログファイルへ記載するようにしたいです。
>起動開始前に、ログファイルの中身をクリアーさせるコード

予め決まったファイル名とし、
作成の都度上書き（あるいは削除して新規作成）する動作でいいですか？
これの場合、
>マクロは1日3回起動させる為
とのことですから、2回目が走ると1回目のログが消えます。
それでいいですか？

私だったら、YYYYMMDDHHMM.log といったファイル名にし
実行の都度作成し、
数日後、数週後など適当な時に適当な範囲のlogファイルを手作業で削除します。

ロゴの出力機能は、仕様がブレそうなので，まだ組み込んでいません。

Option Explicit

Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員マスタ.xlsx"
Const TblSheet = "職員マスタ420227"

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 2
With tgBook.Sheets(tgSheet)
Do
If .Cells(r, 2).Value = "" Then Exit Do

If IsNumeric(.Cells(r, 2).Value) = False Then
'ここで職員番号が数値ではないログを出力
ElseIf .Cells(r, 4).Value <> "" Then
'ここでアドレスが既に埋まっているログを出力
Else
HitAddress = GetMailAdress(.Cells(r, 2).Value)
If HitAddress <> "Not Found" Then
.Cells(r, 4).Value = HitAddress
'ここでアドレスをセットしたログを出力
Else
'ここで職員が見つからなかったログを出力
End If
End If
r = r + 1
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close

End Sub

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As Long) As String

Dim SQL As String
Dim cn As Object
Dim rs As Object

'SQL文の実行準備
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open TblBook

'SQL文の組立
SQL = ""
SQL = SQL & "select [メールアドレス]" & vbCrLf
SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [職員番号] = " & sNum & vbCrLf

rs.Open SQL, cn

'ヒットする行が無かったら抜ける
If rs.EOF = True Then
GetMailAdress = "Not Found"
Exit Function
Else
GetMailAdress = rs("メールアドレス")
End If

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

補足

早速のご教示ありがとうございました。
修正頂いたマクロを実行し、文字記載の列はエラーにならずに無視されて、正常終了出来ました。

②のファイル名、シート名、タイトル名が今後変更になりそうなのですが、ご教示頂いたマクロの何処を修正すれば良いのか分かりませんでした。
①のファイルについても、変更があるかもです。

取り合えず、②ファイルのシートは『職員DB』へ変更、職員IDが入っている列はA列でタイトル名は『nimsID』へ変更。
メールアドレスが入っている列はP列へ変更、タイトル名は『メールアドレス』になります。
今後も更に変更になる可能性がありますので、コードの変更方法のご教示を頂けましたら大変助かります。
職員DB.xlsxに記載されているメールアドレスは、無記入の行が度々ありましたが、マクロ起動時、エラーが出なかったので問題ないと思われます、そのように作られているマクロでしょうか？

2024参画者リストまとめ_20240311.xlsxファイルは、１日１回程度、手動でファイルを開いてデータを確認する予定です。
ログファイルは、可能でしたら、マクロの正常稼働状況(マクロ起動開始時刻と終了時刻と処理数)とメールアドレスを抽出出来なかった職員IDを記載させたいです。
また、ログのファイル名ですが、お薦めの『YYYYMMDDHHMM_メール抽出.log』を希望します。
我儘なお願いで、大変恐縮ですが、
マクロ起動前にログファイルを削除し、再作製するやり方と、ログファイルを残すやり方のコードを
両方記載して頂き、切り替えが出来るよう、コメント文にするとか、コードを部分的に修正すれば良いようにして頂けましたら嬉しいです。
大変お手数ですが、宜しくお願いします。

回答No.2

HohoPapa

職員番号は数値と思っていました。
文字列とのことであれば、
以下のコードで行けるのではないかと思います。

Option Explicit

Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員マスタ.xlsx"
Const TblSheet = "職員マスタ420227"

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 2
With tgBook.Sheets(tgSheet)
Do
If .Cells(r, 2).Value = "" Then Exit Do
If .Cells(r, 4).Value = "" Then
HitAddress = GetMailAdress(.Cells(r, 2).Text)
If HitAddress <> "Not Found" Then
.Cells(r, 4).Value = HitAddress
End If
End If
r = r + 1
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close

End Sub

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As String) As String

Dim SQL As String
Dim cn As Object
Dim rs As Object

'SQL文の実行準備
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open TblBook

'SQL文の組立
SQL = ""
SQL = SQL & "select [メールアドレス]" & vbCrLf
SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [職員番号] = '" & sNum & "'" & vbCrLf
rs.Open SQL, cn

'ヒットする行が無かったら抜ける
If rs.EOF = True Then
GetMailAdress = "Not Found"
Exit Function
Else
GetMailAdress = rs("メールアドレス")
End If

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

補足

早速のコードのご教示有り難うございました。

①の2024参画者リストまとめ_20240311.xlsxは、
複数のExcelファイルから特定列データを連結して作成しています。

①のファイルは以下のコードで書式を設定して作成しているので、B列は数値の値が入っていると認識しています。
しかしながら、特例でB列に1行のみ、メッセージ的な値が入っております。これは、備忘録の意味で後から手動で書き込んだものになります。

sakiSheet.Range("B:B").Value = sakiSheet.Range("B:B").Value
Range("B:B").Replace What:=vbTab, Replacement:=""

①ファイルのB列は、通常は数値として認識し抽出するが、メッセージ的な値が入っている行は無視するようにしたいのですが可能でしょうか？

また、お願いがあります。
このマクロはタイムスケジューラーで自動起動させますので、マクロ開始、終了時刻とメールアドレス抽出状態をログファイルへ記載するようにしたいです。
マクロは1日3回起動させる為、ログファイルはメールアドレス抽出マクロの起動開始前に、ログファイルの中身をクリアーさせるコードを作成する事は可能でしょうか？
大変お手数をおかけしますが宜しくお願い致します。

回答No.1

HohoPapa

"参画者リスト"シートにメールアドレスが埋まっていなかったら
"職員マスタ420227"から職員番号をキーにメールアドレスを取得して埋める。
という動作ということでいいですね？

vlookupにこだわるとか、メールアドレスが取得できるように
"参画者リスト"シートにvlookup関数を埋めることを期待してはいないですね？
また、
>①のD列へ挿入したい
とは、
行挿入（あるいは列挿入）をするということではないですね？

SQLを使ったVBAのコードを書いてみましたので、
よかったら参考にしてください。

なお、
"職員マスタ420227"シートについては、
A1=職員番号
C1=メールアドレス
という列名になっている前提です。

以下に気になった点を列挙します。

タスクスケジューラーを使った自動運転をする場合、
https://website-note.net/windows/how-to-open-an-excel-file-from-task/
のようにすれば、あえて、
2024年度-参画者リスト作成.vbs　といったスクリプトを用意する必要はありません。
なにか意図したものがあれば気にしないでください。

自動運転するのであれば、マクロブックを開いたら自動的に開始し
マクロの終盤でマクロブック自身を閉じる必要があります。
この仕組みを組み込むと、勝手に閉じてしまうので
ソースコードの修正をする機会を失ってしまいます。
（なにか手当が必要です）

また、無人運転をさせるのでしょうから
実行ログを残す機能も欲しいと思います。

どこまで理解されているのかよくわからなかったので
転記部分だけのコードをポストしました。
コードに限らず、コメントを頂ければ助言できるだろうと思います。

Option Explicit

Const tgBookName = "D:\TestDir\2024参画者リストまとめ_20240311.xlsx"
Const tgSheet = "参画者リスト"
Const TblBook = "D:\TestDir\職員マスタ.xlsx"
Const TblSheet = "職員マスタ420227"

Sub Mainjob()

Dim tgBook As Workbook
Dim r As Long
Dim HitAddress As String

'対象ブックを開く
Set tgBook = Workbooks.Open(tgBookName)

'メイン処理
r = 2
With tgBook.Sheets(tgSheet)
Do
If .Cells(r, 2).Value = "" Then Exit Do
If .Cells(r, 4).Value = "" Then
HitAddress = GetMailAdress(.Cells(r, 2).Value)
If HitAddress <> "Not Found" Then
.Cells(r, 4).Value = HitAddress
End If
End If
r = r + 1
Loop
End With

'対象ブックを保存して閉じる
tgBook.Save
tgBook.Close

End Sub

'職員番号を引数にメールアドレスを返す関数
Function GetMailAdress(sNum As Long) As String

Dim SQL As String
Dim cn As Object
Dim rs As Object

'SQL文の実行準備
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open TblBook

'SQL文の組立
SQL = ""
SQL = SQL & "select [メールアドレス]" & vbCrLf
SQL = SQL & "FROM [" & TblSheet & "$A1:Z50000]" & vbCrLf
SQL = SQL & "Where [職員番号] = " & sNum & vbCrLf
rs.Open SQL, cn

'ヒットする行が無かったら抜ける
If rs.EOF = True Then
GetMailAdress = "Not Found"
Exit Function
Else
GetMailAdress = rs("メールアドレス")
End If

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Function

補足

早速ご教示頂きまして、誠に有難うございます。
SQL文は今回初めてです。コードがスッキリしていて、使い慣れれば便利になると感じました。

マクロを起動させると、正常起動したようですが、
HitAddress = GetMailAdress(.Cells(r, 2).Value)のコードの所で、『型が一致しません』のエラーが出ました。
①のファイルへは途中までメールアドレスが書き込まれています。
職員番号を確認すると、数字以外の『23NM5038で処理』が書かれたセルの行で止まっています。
対処方法がお分かりでしたら、ご教示頂けると助かります。
①のファイルは、サーバからファイルのコピーや削除を行った後、Excelのマクロを起動して作成しております。
EXCELのマクロでサーバからファイルのコピーや削除のコードを書く事が難しかった為、バッチファイルで作成する事にしました。
4月1日より、更に、今回お聞きしたマクロの追加が必要になりましたので、今回は今動いているバッチファイル中で、このマクロを設定しようと思っています。