• ベストアンサー

Constで現在日付と文字を合わせた値を変数へ代入

質問時刻=2024/03/11 22:15、タイトル名=『vlookupを使ったマクロの書き方』で、質問させて頂き、HohoPapa様にご教示頂いたマクロのコードについて、メールアドレスが入っているファイルのシート名に変更が生じましてコードの変更が必要になりました。 修正箇所は、『Const TblSheet = "職員マスタ"』になります。 色々と修正を加えて見ましたが、エラーが出てしまいマクロの正常稼働で出来ませんでした。 変更点は、シート名=『職員マスタ』を『employee-20240510』への変更になります。『employee-』は固定文字ですが、『20240510』は現在の日付を指定したいです。 Const TblSheet = "employee-" & Format(Now, "yyyymmdd")と しましたが、エラーがでてしまいます。 お忙しい中、大変恐縮ですが、お手すきの時に対応させたマクロのご教示を頂けましたら大変助かります。 上記1行のマクロのコードのみ、ご教示頂ければ大丈夫です。 今現在まで、ルーチンワークとして便利に使わせて頂いております。 ------以下は現在のマクロのコードです----------------- Option Explicit Const tgSheet = "Sheet1" Const TblBook = "C:\Users\watan\Documents\27_EXCEL教習\TEST\11_2024-課題参画者リスト\スクリプト\職員DB.xlsx" Const TblSheet = "職員マスタ" 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 '1つのログファイルに常に新規作成(処理の都度上書き)する。 LogFile = ThisWorkbook.Path & "\" & _ "MentLog.csv" Open LogFile For Output As #2 Close #2 Logput "M0", "", "", "", "転記処理開始", "" '対象ファイル名の組立 tgBookName = _ "C:\Users\watan\Documents\27_EXCEL教習\TEST\11_2024-課題参画者リスト\出力結果\" & _ Format(Now, "YYYY") & _ "参画者リストまとめ_" & _ Format(Now, "YYYYMMDD") & _ ".xlsx" '対象ブックを開く Set tgBook = Workbooks.Open(tgBookName) 'Main処理 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, "", "職員番号が不正", .Cells(r, 1).Value Else HitAddress = GetMailAdress(.Cells(r, NumCol).Value) If HitAddress = "Not Found" Then Logput "M3", Format(r, "0"), _ .Cells(r, NumCol).Value, "", "職員番号が見つからない", .Cells(r, 1).Value ElseIf ((HitAddress = "Null") Or (HitAddress = "")) Then Logput "M4", Format(r, "0"), _ .Cells(r, NumCol).Value, "", "マスターのメールアドレスが空欄", .Cells(r, 1).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, .Cells(r, 1).Value Else Logput "M6", Format(r, "0"), _ .Cells(r, NumCol).Value, .Cells(r, AddressCol).Value, "既に同じアドレスが埋まっている", .Cells(r, 1).Value End If Else .Cells(r, AddressCol).Value = HitAddress Logput "M1", Format(r, "0"), _ .Cells(r, NumCol).Value, HitAddress, "メールアドレスをセット", .Cells(r, 1).Value End If End If 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 [職員番号] = " & sNum & vbCrLf rs.Open SQL, cn 'ヒットする行が無かったら抜ける If rs.EOF = True Then GetMailAdress = "Not Found" 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

質問者が選んだベストアンサー

  • ベストアンサー
  • SI299792
  • ベストアンサー率48% (722/1494)
回答No.2

Const は定数なので、数式は入れれません。   Const TblSheet = "employee-" & Format(Now, "yyyymmdd")     👇   Dim TblSheet As String   TblSheet = "employee-" & Format(Date, "yyyymmdd") でできると思います。

nnirosan
質問者

お礼

作業ホルダーへ保存した職員DBのシート名を『職員マスタ』へ変更する事を思いつきました。シート名変更マクロを作成し、作成頂きましたマクロはそのままで無事メールアドレスを追加する事出来ましたので、これで今回のご質問は閉じます。有難うございました。

nnirosan
質問者

補足

質問内容に誤りがある事に今気が付きました。 大変申し訳ありません。 メール情報が入っているファイルは、毎日更新はしておりませんでした。 メール情報が追加されたと思われるタイミングで、手動でサーバから作業ホルダーへコピーしております。よって、シート名=employee-20240510はファイルを更新した時の日付のままになります。 下記の職員DB.xlsxのシートはemployee-20240510の1つだけになります。 C:\Users\watan\Documents\27_EXCEL教習\TEST\11_2024-課題参画者リスト\スクリプト\職員DB.xlsx メール挿入マクロはタイムスケジューラで毎日5回稼働させますが、職員DB.xlsxは不定期に更新するので、ご教示頂いた下記で実行すると正常稼働は出来ない事になる事がわかりました。 Dim TblSheet As String TblSheet = "employee-" & Format(Date, "yyyymmdd") 現在のマクロでは、Const TblSheet = "職員マスタ" としていますが、シート名指定の代わりに、シート1(シート名は指定せず1番目のシート)として、マクロに反映する事は可能でしょうか? もし、それが可能でしたら、そのコードのご教示を頂けましたら大変助かります。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (1)

回答No.1

>Const TblSheet = "employee-" & Format(Now, "yyyymmdd")と >しましたが、エラーがでてしまいます。 Constに変数は代入出来ないようですね。 Format(Now, "yyyymmdd")が変数扱いで、エラーになっていると思います。 https://vba-create.jp/vba-error-variable-not-const/

nnirosan
質問者

お礼

ご教示ありがとうございました。 シート名をマクロで変更し、無事メールアドレス追加が出来ました。 頂いた情報は、今回大変参考になりました。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • excel vba で .mdb のデータ抽出

    excel vba で postdata.mdbのpostレコードから条件に合うデータを抽出しようとしています。 数日間、いろいろ調べていますが分かりません。 おそらく、SQLの部分だと思うのですが・・・ adoは初めて使う素人なので教えていただけないでしょうか。 On Error GoTo ErrGyo Set cn = New ADODB.Connection cn.Provider = "Microsoft.Jet.OLEDB.4.0" cn.Open ThisWorkbook.Path & "\postdata.mdb" Dim Rs As ADODB.Recordset Dim SQL As String Dim T_ken As String Dim T_si As String Dim T_mati As String Dim i As Long T_ken = TextBox1.Value  ’フォームにテキストボックス T_si = TextBox2.Value T_mati = TextBox3.Value SQL = "SELECT * FROM post WHERE ken like '" & T_ken & "' and si LIKE '" & T_si & "' and mati LIKE '" & T_mati & "'" Set Rs = New ADODB.Recordset Rs.Open SQL, cn, adOpenForwardOnly, adLockReadOnly MsgBox Rs.RecordCount  ’ここでチェックすると -1 となる??? If Rs.RecordCount = 0 Then MsgBox "該当するレコードは見つかりませんでした。", vbInformation Else For i = 1 To Rs.RecordCount Cells(i, 1) = Rs!num Cells(i, 2) = Rs!ken Cells(i, 3) = Rs!si Cells(i, 4) = Rs!mati Rs.MoveNext Next End If Rs.Close: Set Rs = Nothing cn.Close: Set cn = Nothing Exit Sub ErrGyo: MsgBox "postdataへの接続に失敗しました", vbCritical

  • Excel VBA 列の最後の値を代入

    たびたびすみません。 指定したセルの、最終列の値を、任意のセルに入れたいのですが、 オブジェクトが必要です、というエラーがでます。 Sub 単価代入() Dim i As Integer Application.ScreenUpdating = False For i = Range("IV2").End(xlToLeft).Column To 1 Step -1 If InStr(Cells(2, i).Value, "単価") > 0 Then Cells(3, i).Value = Cells(3, i).End(xlToRight).Column.Value End If Next i Application.ScreenUpdating = True End Sub Cells(3, i).Value = のあとの指定方法がまずいのかと思いますが。。 どうぞ宜しくお願い致します。

  • 検索マクロ

    下記のマクロは、検索文字でシートを検索し、そのセルアドレス情報を シートを追加して表示する機能ですが、BOOK全体に検索し、シート名を含めて表示するには、xxxxのところをどのように変更すればいいか。よろしくお願いします。 Sub kennsaku_Macro1() Dim ret Dim r As Range Dim adr As String Dim cnt As Long Dim psw As Boolean Dim mySht, adSht, ws As Worksheet Set mySht = ActiveSheet ret = Application.InputBox("検索文字列を入力してください") If TypeName(ret) <> "Boolean" Then With mySht.Cells Set r = .Find(ret, LookIn:=xlValues, lookat:=xlPart) If Not r Is Nothing Then adr = r.Address cnt = 2 '2行目から表示 xxxxxxxxxxxxx For Each ws In Worksheets If ws.Name = "検索結果" & ret Then psw = True Exit For End If Next ws If psw Then Set adSht = ws adSht.Cells.ClearContents Else Set adSht = Worksheets.Add adSht.Name = "検索結果" & ret End If adSht.Cells(cnt, 1).Value = r.Value adSht.Cells(cnt, 2).Value = xxxx 'シート名 adSht.Cells(cnt, 3).Value = adr Do Set r = .FindNext(r) If r.Address = adr Then Exit Do Else cnt = cnt + 1 adSht.Cells(cnt, 1).Value = r.Value adSht.Cells(cnt, 2).Value = xxxx 'シート名 adSht.Cells(cnt, 3).Value = r.Address End If Loop End If End With End If adSht.Cells(1, 1).Value = "項目" adSht.Cells(1, 2).Value = "シート名" adSht.Cells(1, 3).Value = "セルアドレス" mySht.Activate End Sub

  • エクセル マクロ 教えてください。

    sheet1に (a1=No. b1=月日 C1=項目 d1=収入 e1=支出 f1=摘要 G1=店名)項目を作りそれらをユーザーフォームを作り入力したいです。 この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。 本当に良いですか? ", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub

  • VBAtest

    VBAおn以下の Sheets("OP").Select Dim atai As String atai = Cells(2, 2).Value Dim datedata(40) As String For j = 0 To 40 If Cells(j + 3, 2).Value = "" Then Else datedata(j) = Cells(j + 3, 2).Value End If Next Dim shihyou As String For i = 1 To 2 shihyou = Cells(2, i + 2).Cells.Value Sheets(shihyou).Select Dim tmp_c As Integer For r = 1 To 10 tmp_c = 0 For c = 1 To 10 If tmp_c = 0 Then If Sheets(shihyou).Cells(r, c).Value = atai Then tmp_c = c End If Else Dim vals(40) As String For k = 0 To 40 For l = 1 To r + 41 For m = 1 To tmp_c - 1 If Sheets(shihyou).Cells(l, m).Value = datedata(k) Then vals(k) = Sheets(shihyou).Cells(l, tmp_c).Value End If Next Next Next End If Next Next Sheets("OP").Select For k = 3 To 43 Cells(k, i + 2).Value = vals(k - 3) Next Next End Sub

  • EXCELへのデータ出力

    VB6.0で開発しています。 下記のようにEXCELへのデータ出力は出来たのですが EXCELのシートのA列とB列は文字列にしたいのです。 今はA列とB列に数字を入れると右詰になってしまいます。 どうすればいいでしょうか? 教えてください。 Dim s3cn_ado As variant Dim dsn As String Dim tbl As String Dim tky As String Dim sql As String Dim rs As variant Dim fnm As String Dim mds As boolean Dim fno As Integer Dim i As Integer Dim j As Integer Dim k As long Dim s As String Dim ct As long Dim exl As Object dsn = "dsn=SAK3_ADO;uid=SAK;pwd=SAK" tbl = "sak.受注m" tky = "受注番号 = ''" '0 件のダミー問い合わせ用のキー" fnm = "g:\tmp\test.xls" mds = true set s3cn_ado = CreateObject ("ADODB.Connection") s3cn_ado.Open dsn sql = "select * from " & tbl & " where " & tky set rs = s3cn_ado.Execute(sql) j = rs.fields.count - 1 redim ctyp(j) as boolean For i = 0 to j select case rs(i).type case 131, 139 ctyp(i) = true case else ctyp(i) = false end select Next rs.close Set exl = CreateObject("Excel.Application") exl.Application.Visible = True exl.Application.Workbooks.Open FileName:=fnm k = 1 if mds then k = 2 end if s3cn_ado.BeginTrans on error resume next for k = k to 65536 s = "" If exl.Cells(k, 1) = "" Then Exit For For i = 0 To j if ctyp(i) then s = s & "," & exl.Cells(k, i + 1) else s = s & ",'" & exl.Cells(k, i + 1) & "'" end if Next s = mid(s, 2) sql = "insert into " & tbl & " values (" & s & ")" s3cn_ado.Execute sql if err <> 0 then s3cn_ado.RollbackTrans close fno s3cn_ado.Close msgbox "更新エラー" & chr(10) & err & ": " & error _ & chr(10) & ct + 1 & " 件目に問題あり" _ & chr(10) & sql end end if ct = ct + 1 next s3cn_ado.CommitTrans on error goto 0 exl.Application.DisplayAlerts = False exl.Application.Quit s3cn_ado.Close

  • VBAで、定数式が必要ですのエラー対応

    指定のファイルをフォルダAからフォルダBへ移動させるというvbaを 見つけたのですが、 サンプルの表記は「"C:\Data\A"」と直接場所をしていしたものなので、 参照するフォルダ場所として、セルC1を参照させようと、 「Range("C1")」と書き直したところ、 「コンパイルエラー:定数式が必要です」とエラーになってしまいます。 どの様に書き直せばよいのでしょうか? どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Const FolderA = Range("C1") 'エラー発生 'Const FolderA = "C:\Data\A" サンプルの表記   Const FolderB = "C:\Data\B" Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "A").Value <> "" Then ' fileName = ws.Cells(r, "A").Value & ".xls" fileName = ws.Cells(r, "A").Value If fso.FileExists(FolderA & "\" & fileName) = True Then fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName End If End If Next End Sub

  • セルの値から任意の文字のみを抽出する

    こんにちは。 VBA勉強中です。 どうしても詰まってしまったので力を貸してください。・゜・(ノД`)・゜・。 Sheet1にはA列~J列にデータが入っています(行数は3行目~□行目・・・都度変わります) Sheet2には抽出したい文字の一覧(仮に禁止ワードとします)がB列5行目~○行目まで入ってます。 質問としてはSheet1のB列、D列、F列のそれぞれの値より禁止ワードを抽出する。 1つのセルに禁止ワードが0~最大5つ入っている時にK列から→方向に禁止ワードを並べて行くといった 感じです。 わかりにくくてすみませんが宜しくお願い致します。 以下自分で考えてみたコードです。。 これだと始めのB列のみ抽出に成功しましたがその他の列からは抽出できず・・・。゜(PД`q。)゜。 列Bで使用したコードをD列、F列にも使えると下に数値のみ変えて羅列しただけだからでしょうか;w; 本当に初心者ですみません。。 以下コードです。 Sub 禁止ワード抽出() Dim SR As Integer , LR As Integer, SR2 As Integer , LR2 As Integer , LR3 As Integer , LR4 As Integer Dim i As Long , j As Long , k As Long , m As Long Dim KINSHI As Variant SR = 3 SR2 =5 LR = Sheets("Sheet1").Range("B" Rows.Count).End(xlUp).Row LR2 = Sheets("Sheet1").Range("D" Rows.Count).End(xlUp).Row LR3 = Sheets("Sheet1").Range("F" Rows.Count).End(xlUp).Row LR4 = Sheets("Sheet2").Range("B" Rows.Count).End(xlUp).Row For j = SR2 To LR4 KINSHI = Sheets("Sheet2").Cells(j , 2).Value For i = SR To LR If Sheets(Sheet1).Cells(i , 2).Value Like ("*" & KINSHI & "*") Then If Cells(i , 10) = "" Then Cells(i , 10) = KINSHI Else   If Cells(i , 10 + 1) = "" Then Cells(i , 10 + 1) = KINSHI            Else   If Cells(i , 10 + 2) = "" Then Cells(i , 10 + 2) = KINSHI Else   If Cells(i , 10 + 3) = "" Then Cells(i , 10 + 3) = KINSHI Else   If Cells(i , 10 + 4) = "" Then Cells(i , 10 + 4) = KINSHI End If End If End If End If End If End If Next i , j 以下上記コードをD列、F列バージョンで並べています・・・・ End Sub 恐らくOffsetプロパティを使う方がいいと思いましたが中々うまくいかず 自分なりに色々考えてみてこんな残念な結果になってしまいましたが 皆様のお力添えどうぞ宜しくお願い致します。

  • VBAのデバックをどなたかお手伝いください。

    もちろん自分でも調べてはいるのですが、急いでいるため、もしどなたか教えてくだされば大変助かります。 この(下記の)Then 以降からがわかりません。 Do Until rs.EOF '該当レコードあり If rs!MCD = "3162" Then '--------------------------------------------- strcriteria = "CAT = '" & rs!CAT & "'" ' --- A rs2.Find strcriteria, 0, adSearchForward If rs2.EOF Then ' Else rs!仕入単価世代1 = rs!仕入単価 rs!仕入単価 = rs2!discount End If '--------------------------------------------- rs!更新日 = Now() rs.Update End If 情報が不足していればお答えします。どうぞ宜しくお願いいたします。 (補足)これより前に入力されているのは以下のものです。 Dim cn As ADODB.Connection Dim cn2 As ADODB.Connection Dim rs As ADODB.Recordset Dim rs2 As ADODB.Recordset Dim strmsg As String Dim lngRet As Long Dim strcriteria As String Set cn = CurrentProject.Connection Set rs = New ADODB.Recordset Set cn2 = CurrentProject.Connection Set rs2 = New ADODB.Recordset rs.Open "商品2_T", cn, adOpenKeyset, adLockOptimistic rs2.Open "商品2_T25discountてすと", cn2, adOpenKeyset, adLockOptimistic

  • 【Excel VBA】日付の代入

    現在以下の操作を行いたく、コードを作成しています。 ・20~23行で各最大値を抽出し、C列に代入する ・最大値に紐づく日付をD列に代入する ・D列の日付が入ったセルを改行し、 2行目に"(曜日)"を入力する <現在のExcelデータ詳細> A20:"処理1" A21:"処理2" A22:"処理3" A23:"処理4" B19~AF19:日付 B20~AF23:任意の数字 C31:処理1の最大値 C33:処理2の最大値 C35:処理3の最大値 C37:処理4の最大値 D31、D33、D35、D37:日付 L(曜日)を入力予定 最大値に紐づく日付をD列に代入するところで 躓いています。 ご教示いただけないでしょうか。 現在のコードは下記の通りです。 Sub 最大値の取得() Dim max As Long Dim row As Integer Dim column As Integer For row = 20 To 23 max = 0 For column = 2 To 32 If Cells(row, column).Value > max Then max = Cells(row, column).Value End If Next Cells((row - 20) * 2 + 31, 3).Value = max For i = 4 To 1 Step -4 '編集中 Cells((row - 20) * 2 + 31, 4).Value = Cells(row - i, column - 1) '編集中 Next End Sub