Visual Basic

質問時刻＝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 '１つのログファイルに常に新規作成（処理の都度上書き）する。 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

以下のサイトにVBAのサンプルがあったので見ていたのですが、「Range("A1").AutoFilterMode」という箇所があります。RangeオブジェクトにAutoFilterModeプロパティは無いと思いますし、実行するとエラーになりますが、このコードについてあっているのか、間違っているのか、どちらになるでしょうか？ https://github.com/carvetighter/VBA-Code-Library/blame/master/Mod_Autofilter.bas

Excelで添付のようなリストから月末に ・A列の請求期間をフィルター（基本月ごと、1月1日～1月31日迄等） ・Ｂ列の得意先ごとにフィルター結果の上から1件ずつレ点を入れ得意先1件ずつ印刷 上記のような作業を毎月行っています。 Ａ列の日付は顧客ごとに末締めや15日締め等あるので手動で問題無いのですが、Ｂ列の得意先ごとに1件ずつチェックを入れて印刷するのが手間なので日付フィルター後にボタン1発で全得意先分を順番に印刷できるようにしたいです。 どなたか知恵をお貸し頂けませんでしょうか。

現在、月毎にシート別になっている勤務表の管理をしており、初心者ながらExcel VBAを使って効率的に作成したいと思っています。 勤務表は1行目に日付、A列に従業員の名前が入っています。 その中でつまづいている箇所がありますので以下の2点について教えてください。 ① 従業員の中に三交代制の従業員がいます。 　A、B、Cの3つの班に分かれており、その日がどの班なのか分かるように日付の下の行に「A B C A B C ･･･」と順番に記載したいですがどのようにしたら良いでしょうか？ 　また、この時に月を跨ぐとAから始まらない(前月がBで終わると翌月1日はCから始まる)と思うのですが、シートを跨いでABCの3つが続いていくようにしたいです。 ② 前記①が完了したら、三交代制の従業員の隣にそれぞれABCの表記をし、日付のABCと従業員のABCがそれぞれ交わる日のセルに「出勤」と入れたいです。 職場のパソコンで作業しているため、現在手元にデータがなく、参考となる画像がつけられずに分かりづらいとは思いますがご回答頂けると助かります。 よろしくお願いします。

Visualbasic2013でFormアプリケーションを開発しております。 Form上にElementhostを配置しWPFの表示も行っております。 OSがWindows11(23H2)の場合にInitializecomponentで異常終了する事象が 発生する事が分かりました。23H2が適用されていない場合は異常終了は 発生しません。 異常終了発生時のイベントログには以下が出力されています。 障害が発生しているモジュール名: ucrtbase.dll、バージョン: 10.0.22621.3374、タイム スタンプ: 0xac92626e 例外コード: 0xc0000409 障害オフセット: 0x0009e34b 障害が発生しているプロセス ID: 0x0x2378 障害が発生しているアプリケーションの開始時刻: 0x0x1DA8963F1A2F9E9 上記の異常終了を改善する方法が分かる方がいらっしゃいましたらご教授頂けないでしょうか。

windows11でvisualbasic2013でFormアプリケーションを開発しており ElementHostを利用してWPFを利用しております。 全ての端末ではないのですがシステムを起動した際に「Controls.Add(Me.ElementHost2)」 で異常終了する端末が存在します。 異常終了する端末のOSはWindows11です。 同じOSであっても異常終了しない端末も存在します。 異常終了する端末はtry/chachで例外も補足されません。 異常終了が発生しないように改善したいのですが、例外も補足できず どのように対応すればよいのか分からない状況です。 分かる方がいらっしゃればご教授頂けないでしょうか。

Excel請求書から出力したPDFファイルをメールソフトのThunderbirdでメールに添付して送信したいのですが、 添付ファイルのパスが間違っているのか「＊＊＊.pdfファイルが存在しないためメッセージに添付できませんでした。」とエラーになってしまいます。 PDFファイル出力は問題無く出来ており、メール自体は作成できるところまでは出来ているのですが、肝心のファイル添付が出来なくて困っております、どなたかお助け願えませんでしょうか。 ※PDFファイルの保存場所は任意に選択⇒ファイル名は顧客名で都度出力される形になってます。 Sub PDF出力メール送信テスト用() Dim fname As String Dim pdfname1 As String Dim pdfname2 As String Dim rtn As Long Dim wsh As Object If MsgBox("PDFをメール送信する場合はＯＫ、送信しない、または間違ってこのボタンをクリックした場合はキャンセルをクリックしてください。", vbOKCancel) = vbCancel Then End End If 'pdfname1は会社名、pdfname2は部署名、両方足して『顧客名.pdf』になるようにしています pdfname1 = Range("a4").Text pdfname2 = Range("a5").Text '保存ファイル名及び保存場所の設定 fname = Application.GetSaveAsFilename("【御請求書】" & pdfname1 & " " & pdfname2 & " 御中", "PDFファイル,*.pdf") 'キャンセルボタン押下時 If fname = "False" Then Exit Sub 'ファイルの存在確認 If Dir(fname) <> "" Then rtn = MsgBox(fname & " が存在します。上書きしますか？", vbOKCancel + vbQuestion, "確認") 'キャンセルボタン押下時 If rtn = vbCancel Then Exit Sub End If '印刷順にシートを並び替え Worksheets("請求書").Move Before:=Worksheets("請求書ひな形") Worksheets("請求書").Select Worksheets("請求書ひな形").Select False Worksheets("請求書ひな形").Activate ' 請求書PDF出力 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname MsgBox fname & " 出力完了" '元通りにシートを並び替え Worksheets("請求書ひな形").Move Before:=Worksheets("請求書") Worksheets("請求書ひな形").Select Dim sPath As String Dim mailTo As String Dim subject As String Dim preface As String Dim mailBody As String Dim attachPath As String sPath = """C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"" -compose " '送信先アドレスはExcelのx1セルに反映 mailTo = Range("x1").Value subject = "御請求書の送付について" preface = pdfname1 & pdfname2 & " 御中" & vbNewLine & vbNewLine & "いつもお世話になります。" & vbNewLine & "御請求書をお送り致しますのでご確認下さい。" & vbNewLine & vbNewLine & "以上、宜しくお願い致します。" mailBody = preface '添付ファイルのパスはfnameではダメなんでしょうか？ attachPath = fname Shell sPath & "to=" & mailTo & ",subject=" & subject & ",body=" & mailBody & "," & "attachment=" & attachPath End Sub

お詳しい方宜しくお願い致します。 一番初めにコードを提供して頂けた方にAmazonギフトコード3,000円提供します。 急ぎでどうしてもエラーがないコードが知りたい為です。 Excelで"全体"と"分析"シート以外のシート(ここでは”A”とB”)を"全体"シートに転記したいです。(添付ファイルはAシートしか載せていません) 以下のコードをマクロで実行すると"全体"シートに集計はちゃんとされていますが、エラーが出ます。 実行時エラー'1004': 'Select' メソッドは失敗しました '_Worksheet'オブジェクト 最初のシートのcellsの行数カウントとシート選択部分が間違えているのが原因のようですが、コードが分からなくて・・・以下、VBAです。 ----------------------------------------------------------- Sub 複数シートのデータを1枚のシートにまとめる_シートオプションあり() '複数シートを１枚 '全体シートがあるか調べる Dim 貼付シート As Worksheet, あり As Boolean For Each 貼付シート In Worksheets If 貼付シート.Name = "全体" Then あり = True Exit For End If Next 貼付シート ' "全体"が存在しなければメッセージを表示して処理を終了 If あり = False Then MsgBox "貼り付けシートがありません。終了します。", vbInformation, "エラー" Exit Sub End If 'シートの内容クリア Worksheets("全体").Select Range("A1").CurrentRegion.Clear '各シートで処理をする Dim 枚数 As Long, シート As Worksheet 枚数 = 0 Dim 除外辞書 As Object, 対象辞書 As Object, 配列 As Variant Dim 除外配列 As Variant, 対象配列 As Variant, 数 As Long Set 除外辞書 = CreateObject("Scripting.Dictionary") Set 対象辞書 = CreateObject("Scripting.Dictionary") '除外配列に、除外対象を代入 配列 = Split("全体,分析", ",") 除外配列 = 配列 For 数 = 0 To UBound(除外配列) 除外辞書.Add 除外配列(数), "除外" Next 数 'シート名が除外辞書になければ、対象辞書に加える For Each シート In Worksheets If Not 除外辞書.Exists(シート.Name) Then 対象辞書.Add シート.Name, "対象" End If Next シート '対象のキーを、配列に入れる 対象配列 = 対象辞書.keys '配列に入れた対象に、順次処理をする For Each シート In Worksheets(対象配列) Call 複数シートのデータを1枚のシートにまとめる(シート, 枚数) Next End Sub Sub 複数シートのデータを1枚のシートにまとめる(シート As Worksheet, 枚数 As Long) '複数シートを１枚 Application.ScreenUpdating = False ' 画面描画を停止 Application.DisplayAlerts = False ' 警告表示を停止 Dim 右下セル As String, セル範囲 As String, 貼り付け先範囲 As Range, 貼り付け先セル As String 'シートが"全体"ではない場合、"全体"にデータを貼り付ける If シート.Name <> "全体" Then 枚数 = 枚数 + 1 'コピーする範囲を取得 シート.Select Dim 最終行 As Long '表の最終行を決定 最終行 = Cells(Rows.Count, Range("G5").Column).End(xlUp).Row セル範囲 = "A5" & ":" & Cells(最終行, Range("P5").Column).Address(False, False) If 枚数 = 1 Then シート.Range(セル範囲).Copy Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteAll Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteValues Else '表全体の末端を右下セルとして取得 Worksheets("全体").Select Range("A1").CurrentRegion.Select 右下セル = Cells(Selection.Row + Selection.Rows.Count - 1, Range("A1").Column).Address(False, False) 貼り付け先セル = Worksheets("全体").Range(右下セル).Offset(1, 0).Address(False, False) シート.Range(セル範囲).Offset(1, 0).Resize(Range(セル範囲).Rows.Count - 1).Copy Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteAll Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteValues End If End If Worksheets("全体").Activate Application.DisplayAlerts = True ' 警告表示を再開 Application.ScreenUpdating = True ' 画面描画を再開 End Sub

お詳しい方宜しくお願い致します。 Excelで"全体"シート以外のシート(ここでは”A”とB”)を"全体"シートに転記したいです。 以下のコードをマクロで実行すると"全体"シートに集計はちゃんとされていますが、エラーが出ます。 実行時エラー'1004': 'Select' メソッドは失敗しました '_Worksheet'オブジェクト デバッグをするとシート.Selectの部分が間違えていると表記されます。 どのようにコードを変えればエラーが出なくなるでしょうか？ -------------------------------------------------------------------- Sub 複数シートのデータを1枚のシートにまとめる_シートオプションあり() '複数シートを１枚 '全体シートがあるか調べる Dim 貼付シート As Worksheet, あり As Boolean For Each 貼付シート In Worksheets If 貼付シート.Name = "全体" Then あり = True Exit For End If Next 貼付シート ' "全体"が存在しなければメッセージを表示して処理を終了 If あり = False Then MsgBox "貼り付けシートがありません。終了します。", vbInformation, "エラー" Exit Sub End If 'シートの内容クリア Worksheets("全体").Select Range("A1").CurrentRegion.Clear '各シートで処理をする Dim 枚数 as Long, シート As Worksheet 枚数 = 0 Dim 除外辞書 As Object, 対象辞書 As Object, 配列 As Variant Dim 除外配列 As Variant, 対象配列 As Variant, 数 As long Set 除外辞書 = CreateObject("Scripting.Dictionary") Set 対象辞書 = CreateObject("Scripting.Dictionary") '除外配列に、除外対象を代入 配列 = Split("(全体, 分析)のシートを、除いて実行", ",") 除外配列 = 配列 For 数 = 0 To UBound(除外配列) 除外辞書.Add 除外配列( 数 ), "除外" Next 数 'シート名が除外辞書になければ、対象辞書に加える For Each シート In Worksheets If Not 除外辞書.Exists(シート.Name) Then 対象辞書.Add シート.Name, "対象" End If Next シート '対象のキーを、配列に入れる 対象配列 = 対象辞書.keys '配列に入れた対象に、順次処理をする For Each シート In Worksheets(対象配列) Call 複数シートのデータを1枚のシートにまとめる(シート,枚数) Next End Sub Sub 複数シートのデータを1枚のシートにまとめる(シート As Worksheet, 枚数 As Long) '複数シートを１枚 Application.ScreenUpdating = False ' 画面描画を停止 Application.DisplayAlerts = False ' 警告表示を停止 Dim 右下セル As String, セル範囲 As String, 貼り付け先範囲 as Range, 貼り付け先セル As String 'シートが"全体"ではない場合、"全体"にデータを貼り付ける If シート.Name <> "全体" Then 枚数 = 枚数 + 1 'コピーする範囲を取得 シート.Select Dim 最終行 As Long '表の最終行を決定 最終行 = Cells(Rows.Count, Range("G5").Column).End(xlUp).Row セル範囲 = "A5" & ":" & Cells(最終行, Range("P5").Column).Address(False, False) If 枚数 = 1 Then シート.Range(セル範囲).Copy Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteAll Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteValues Else '表全体の末端を右下セルとして取得 Worksheets("全体").Select Range("A1").CurrentRegion.Select 右下セル = Cells(Selection.Row + Selection.Rows.Count - 1, Range("A1").Column).Address(False, False) 貼り付け先セル = Worksheets("全体").Range(右下セル).Offset(1, 0).Address(False, False) シート.Range(セル範囲).Offset(1, 0).Resize(Range(セル範囲).Rows.Count - 1).Copy Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteAll Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteValues End If End If Worksheets("全体").activate Application.DisplayAlerts = true ' 警告表示を再開 Application.ScreenUpdating = True ' 画面描画を再開 End sub

エクセル・vbaに不慣れなためわかりづらかったら申し訳ありません。 コンマ区切りの数字をsplit関数で分割して指定セルに表示したいと考えており、以前質問し回答をいただいた内容でやりたいことが出来るようになりました。 ただし、若干出力場所等の変更を行いたいのですが、変更することが出来ません。 以前はA～C列にあるものをE～H列・J～M列・O～R列に表示する。 その際、A～C列にあるコンマ区切りの数字は3つのものと４つのものがあります。画像の上段部分をご確認ください。 その際のマクロは下記のとおりです。 Sub Test() Dim i As Long, j As Long, k As Long Dim tmp As Variant For i = 1 To 3 For j = 3 To 11 tmp = Split(Cells(j, i).Value, ",") For k = 0 To UBound(tmp) If k < 4 Then Cells(j, i).Offset(0, i * 4 + k).Value = tmp(k) End If Next Next Next End Sub 変更したいのは、AC８～AE16にコンマ区切りの数字があります。 AC列にある数字はAI8～AL16にAD列にある数字はAS8～AV16に AE列にある数字はBC8～BF16に表示したいと考えています。 コンマ区切りの数字は3つのものと４つのものがあります。 （画像の下段部分をご確認ください。） 上記のマクロでは下記の部分を変更する必要なのかと考えていますが、変更方法がわかりません。 お分かりの方教えていただけたら幸いです。 どうぞよろしくお願いいたします。 For k = 0 To UBound(tmp) If k < 4 Then Cells(j, i).Offset(0, i * 4 + k).Value = tmp(k)

エクセルに不慣れなため教えていただけたら幸いです。 A３～A11・B3～B11・C3～C11列にコンマ区切りの数字があります。 列によってはコンマで区切られた数字が3つのものと4つのものが混在しています。 split関数でコンマ区切りの数字を分割してE～Ｈ列・J～M列・O～R列に表示したいと考えています。 先ほど別の質問で下記のマクロを教えていただいたのですが、 その際は、A１～A9にあるものをD～G列に表示するというものでした。 よくよく考えると、A列のみではなく、B・C列と複数の列を コンマ区切りしたいと考えています。 このような場合は、どうしたらよいでしょうか。 vba不慣れなためわかりづらかったら申し訳ありません。 お分かりになられるかたがいらっしゃいましたら教えていただけますでしょうか。 よろしくお願いいたします。 Option Explicit ' Sub Macro1() 　　Dim Rout As Long 　　Dim Colu As Integer 　　Dim Expression As Variant ' 　　For Rout = 1 To Cells(Rows.Count, "A").End(xlUp).Row 　　　　Expression = Cells(Rout, "A") 　　　　Expression = Split(Expression, ",") ' 　　　　For Colu = 0 To UBound(Expression) 　　　　　　Cells(Rout, Colu + 4) = Expression(Colu) 　　Next Colu, Rout End Sub

エクセルに不慣れなため教えていただけたら幸いです。 A列にコンマ区切りの数字があります。 列によってはコンマで区切られた数字が3つのものと4つのものが混在しています。 split関数でコンマ区切りの数字を分割してD～G列に表示したいと考えています。 3つのものだけだとvbaを作成できたのですが、4つ目があるときというプログラムが不明です。 現在作成済みのマクロは下記のとおりです。 Sub test() Dim SH As Worksheet Dim i As Long Set SH = Worksheets("sheet1") For i = 1 To 9 SH.Cells(i, 4).Value = Split(SH.Cells(i, 1).Value, ",")(0) SH.Cells(i, 5).Value = Split(SH.Cells(i, 1).Value, ",")(1) SH.Cells(i, 6).Value = Split(SH.Cells(i, 1).Value, ",")(2) Next i End Sub お手数ですがお分かりになられるかたがいらっしゃいましたら回答いただけたら助かりますのでよろしくお願いいたします。

エクセルにおいて 社員名簿があり ID　氏名で一覧のリストがあります またグーグルドライブ https://drive.google.com/drive/my-drive のフォルダ名称＝社員 https://drive.google.com/drive/folders/13dENSrV_XLIBb1nZ5eDhOHQR81fqtCdl において そのサブフォルダとして フォルダ名称＝1 https://drive.google.com/drive/folders/1Nijm_Nvs43szpdRv-lIUSBwUTfmxmieW 　フォルダ名称＝2　・・・ ID＝1　氏名＝山田　の場合 エクセルシートに　フォルダ1のリンク先を 上記のように ひとりずつクリックして https://drive.google.com/drive/folders/1Nijm_Nvs43szpdRv-lIUSBwUTfmxmie https://drive.google.com/drive/folders/*********** のように しらみつぶしに コピペして エクセルの社員名簿に 貼り付けて行けば 可能ではあるのですが 数万単位ありまして なにか そういう作業をするプログラムを 探しています これはVBAではなくて 他のプログラム言語が必要でしょうか 要は　まとめますと 自分のグーグルドライブにおいて そのなかの　例えば社員フォルダ を開き 各社員のフォルダを開く URLを、もとのエクセルの社員リスト 例えばA1がID A2が氏名 A3が　上記にあるその個人フォルダのURL このURLのコピペを自動化する プログラムを希望するのですが、 御教示くださいませ win10 office365

エクセルにおいて 社員名簿があり ID　氏名で一覧のリストがあります またグーグルドライブ https://drive.google.com/drive/my-drive のフォルダ名称＝社員 https://drive.google.com/drive/folders/13dENSrV_XLIBb1nZ5eDhOHQR81fqtCdl において そのサブフォルダとして フォルダ名称＝1 https://drive.google.com/drive/folders/1Nijm_Nvs43szpdRv-lIUSBwUTfmxmieW 　フォルダ名称＝2　・・・ たとえば1フォルダには　その社員の個人業績の記載されたpdfファイルの 1.pdfがあるとします VBAにより、たとえば ID＝1　氏名＝山田　の場合 エクセルシートに　コマンドボタンを作り コマンドボタンをクリックするとIDを尋ねられるダイアログが 出て来て、そこにIDを入力し、 そこから 上記フォルダを開くVBAを欲しいのですが たとえばID＝1とした場合 グーグルドライブの社員フォルダのなかの1フォルダに ダイレクトに到達させるのは 上記のようなURLを眺めたところ法則性も検討がつかず 無理でしょうか 宜しく御教示お願い致します win10 office365

マクロ中で、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

エクセルでプリンターを選択して印刷するマクロを下記で行っているのですが、プリンター選択ダイアログボックスでプリント中止のキャンセルボタンをクリックしてもキャンセルが有効とならず印刷されてしまいます。マクロ初心者で、どうしたらいいのか困っています。ご教授宜しくお願い致します。 Sub ネットカード印刷() 　 Sheets("ネット入力").Select Application.Dialogs(xlDialogPrinterSetup).Show ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=False Sheets("ネット入力").Select End Sub

ExcelVBAの初歩的な質問です。 【質問内容】 [CheckAcolumnBrank]と[CheckBcolumnBrank]の処理を行った際に、[CheckBcolumnBrank]の結果が[CheckAcolumnBrank]の結果と行数が異なるため（5行ほど多く処理されてしまいます）、[CheckAcolumnBrank]の行数に合わせるコードを知りたいです。 ご見識のある方からの、お知恵の拝借をいただきたく、よろしくお願い申し上げます。 【前提条件】 1.シート1のA5からJ500までの範囲のセルに値が入力されています（空欄セルが不規則にあります）。 2.レコード数は10行程度から450行程度です。 3.A列のセルに値が入っていない場合は、1つ上のセルの値をコピーする挙動です。 4.B列についても、A列と同じ挙動をさせたいです。 5.最終行を求める処理は「GetLastRow」にて行います。 -------------------------------------------- Function GetLastRow() As Long ' 最終行を求める処理 Dim i As Long Dim MaxValue As Long For i = 5 To 500 If Cells(i, "A").Value <> "" Then ' A列からJ列に入力されている値の最大値を求める MaxValue = Application.WorksheetFunction.Max(Range("A" & i & ":J" & i)) If MaxValue > GetLastRow Then GetLastRow = i End If End If Next End Function -------------------------------------------- Private Sub CheckAcolumnBrank() ' A列がブランクの場合、1つ上の値をコピペする処理 Dim currentRow As Long Dim emptyColumns As Boolean Dim Lcont As Long Lcont = GetLastRow Dim ws As Worksheet Set ws = Sheets("シート1") emptyColumns = False ' A列を埋めるループ処理開始 currentRow = 6 Do While currentRow <= Lcont If IsEmpty(ws.Cells(currentRow, 1).Value) Then ws.Cells(currentRow, 1).Value = ws.Cells(currentRow - 1, 1).Value End If ' 終了条件のチェック（E列からJ列がすべて空白、かつA列の1つ上の値が異なる場合に終了） If ws.Cells(currentRow, 5).Value = "" _ And ws.Cells(currentRow, 6).Value = "" _ And ws.Cells(currentRow, 7).Value = "" _ And ws.Cells(currentRow, 8).Value = "" _ And ws.Cells(currentRow, 9).Value = "" _ And ws.Cells(currentRow, 10).Value = "" _ And (ws.Cells(currentRow, 1).Value <> ws.Cells(currentRow - 1, 1).Value) Then Exit Do End If currentRow = currentRow + 1 Loop End Sub -------------------------------------------- Private Sub CheckBcolumnBrank() ' B列がブランクの場合、1つ上の値をコピペする処理 Dim currentRow As Long Dim emptyColumns As Boolean Dim Lcont As Long Lcont = GetLastRow Dim ws As Worksheet Set ws = Sheets("シート1") emptyColumns = False ' ループ開始 currentRow = 6 Do While currentRow <= Lcont If ws.Cells(currentRow, 2).Value = "" Then ws.Cells(currentRow, 2).Value = ws.Cells(currentRow - 1, 2).Value End If ' 終了条件のチェック（E列からJ列がすべて空白、かつB列の1つ上の値が異なる場合に終了） If ws.Cells(currentRow, 5).Value = "" _ And ws.Cells(currentRow, 6).Value = "" _ And ws.Cells(currentRow, 7).Value = "" _ And ws.Cells(currentRow, 8).Value = "" _ And ws.Cells(currentRow, 9).Value = "" _ And ws.Cells(currentRow, 10).Value = "" _ And (ws.Cells(currentRow, 2).Value <> ws.Cells(currentRow - 1, 2).Value) Then Exit Do End If currentRow = currentRow + 1 Loop Set ws = Nothing End Sub --------------------------------------------

大変お世話になっております。 1）Sheet1の2行目から最終行までを取得・コピーをし、同名のシート(Sheet1)の最終行へ追加したいです。 2）BOOK1のSheet1で作業をしており、BOOK2のSheet1へ貼り付けを行います。 3）BOOK1・BOOK2 共に、最終行の判定はC列に文字が入っているものとします。 以下ですと、列が限定されてしまうため、どのようなコードを作成すればよいのか教えていただけると有難い限りです…。 ※将来的には、BOOK1の名前が異なる13シート分をBOOK2（BOOK1と同じ名前のシートが13シートあります）へ同様の作業を行いたいです…。 Sub タイトル行を除き別ファイルに追加() ' Sheets("Sheet1").Activate Rows("2:7").Select Selection.Copy Windows("BOOK2.xlsm").Activate Rows("25:25").Select Selection.Insert Shift:=xlDown Windows("BOOK1.xlsm").Activate Sheets("Sheet1").Activate Application.CutCopyMode = False End Sub ご回答を心よりお待ちしております…。 お手数ですが、どうぞ宜しくお願い申し上げます。

テキストファイル.txtにおける数値 たとえば01234567の８桁を エクセルファイルの（A,1）セルに移動すると 1234567と表示されてしまいます あるコードがあるとしまして 途中省略しますが ・・・・・ .Cells(A, 1).Value = Str(Mid(buf, Pos9 + Len9, Pos10 - (Pos9 + Len9))) これは　あるプログラムの流れということですが これで 1234567　となってしまうので このコードのあとに Range (Cells(A, 1)) .NumberFormatLocal = "@" .Value = Format(.Value, "00000000") （この場合は　８桁とすでにわかっている場合ですが もし先頭に0がいくつ付くかわからない場合のケースも 教えていただけますか） とつけましたが エラーとなります 御教示くださいませ win10 office356

Excelファイルデータの差分比較とそのセル塗りつぶしのマクロを作成したいのですが、今の自分には、下記のマクロでとどまっており、 マクロを実行するファイル内シートにデータをコピーしたり、 マクロ内でその都度、シート名の記載の変更、差分比較データ範囲の変更が必要になり、大変不便で困っております。 やりたい事は、マクロでユーザがExcelのファイルを選択出来て、 そのファイルの中の全シートのデータについて、差分比較とそのそのセルの塗りつぶしをして、塗りつぶしをファイルへ反映させて保存させることです。 どうか、お分かりの方がいらっしゃいましたら、ご教示をお願い出来ますと大変助かります。 各シート内のデータは、列、行共にほぼ同じフォーマットで値が入っています。 それらのシート内のデータで修正した箇所を見つける為、差分比較がしたいです。 例えば、シートが3つの場合は、 1つ目のシートは修正前のデータ、 2つ目のシート内は1つ目のシートの値を部分的に修正したものです。 3つ目のシート内のデータも、1つ目のデータの値を更に再修正したものです。 この3つのシート内のデータを差分比較したいです。 シートの数は、選択したファイルによって異なります。 Sub TEST1() Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用 Set s1 = Worksheets("修正前S装置検索システム") '比較元シート名 Set s2 = Worksheets("修正後装置検索システム") '比較先シート名 Dim arr1 As Variant, arr2 As Variant arr1 = s1.Range("$A$2:$W$548").Value arr2 = s2.Range("$A$2:$W$548").Value For i = 1 To UBound(arr1, 1) For j = 1 To UBound(arr1, 2) If arr1(i, j) <> arr2(i, j) Then '塗りつぶし処理 s1.Cells(i + 1, j).Interior.Color = RGB(255, 0, 0) s2.Cells(i + 1, j).Interior.Color = RGB(102, 255, 51) End If Next Next End Sub