Visual Basic

Excelマクロで悩んでいます。どのように書いたらいいかご教授ください。 ■実行したい内容 添付の画像をご参照いただければと思いますが、指定したテーブルの色のついた行だけを別のシートにコピーしたいです。 ■補足 ・添付の画像では行数を16程度にしていますが実際に使いたい内容では1000行近くあるのと、同シート内でコピーしてほしくない列もあるため、テーブルで指定しています。（図でA～G列はコピー対象だけどH以降は色がついていてもコピー対象外） ですのでテーブルとしていますが、セル指定での範囲選択でなければできない、という話であればそこにはこだわりません。 ・図の結果にあるように、「フォルダB-userB-△」のように、必ず行はセットで転記したいです。 自分で調べてかいた内容では、どうしても「フォルダB-userF-〇」のように、上に詰めて転記されてしまいました。「フォルダBに色をつけたらB～G列すべて色がつく」ようにすれば自分が書いた内容でも対処はできると思いますが、それでは（やりたい内容上）意味がないので、ご相談した次第です。 よろしくお願いします。

VBAで表題の処理を実装しようとしているのですが、コンパイルエラー「ByRef引数の型が一致しません」が出ます。型は合っているように見えるのですが、どうにも解決できません。どなたか原因と対策についてご教示いただけないでしょうか。Public Sub test1() Dim TestArray() As String: ReDim TestArray(1 To 10000, 1 To 4) test2 TestArray End Sub Public Sub test2(ByRef TestArray() As String) ～処理～ End Sub

セルの連結や文字列の扱いで混乱してエラーばかり起こしています。 画像にて状況を説明致します。 ・行を表す、変数i は11 です。 ・N11セルに、画像上部の数式となる様にVBAでコードを入力したいです。 (→C11セルが10桁なら、頭に0を加えて11桁にする。そうでなければ 　　その数字を入力する) ・「Range("N" & i).Formula = 」の続きのコードをご教示願います。 宜しくお願いします。

下記マクロはネットで見つけたものですが、綺麗に動くのですがたまにエラーがでます パスのエラー？で止まるのですが 何か治したいほうが良いところがもしわかれば教えていただきたいです Sub updFileName() 'フォルダパスを宣言 Dim path As String Dim j As Integer 'A2セルの文字をパスに設定 path = Cells(2, 1) & "\" j = 1 'B4セルからファイル名を更新 Do Until Cells(j + 3, 1) = "" 'A列のファイル名をB列のファイル名に更新 Name path & Cells(j + 3, 1) As path & Cells(j + 3, 2) j = j + 1 Loop End Sub ネットは、これです↓ https://skainoblog.com/renamefile/ なんか、変更が途中で止まる、、ことがあるんです。そしたらパスのエラー？とでてました

Excel VBAを独習でき、練習問題を解いてコードをジャッジしてくれるサイト 現在Paizaに課金し、Pythonの説明動画と、演習問題を解いてPython 3のベンダー資格をとることができました 同じことをExcel VBAに関してPaizaでやろうと思いましたが、Excel VBAの講座はないようです オンラインで、Excel VBAの独習ができ、演習問題でコードを書いて、それが正しい解を出力するかジャッジするサイトはあるでしょうか？ 最初～4カ月くらいは無料で試したいです 良ければ課金します OS:Windows 11/10

Excel VBAの質問です (Office2021を使用） 給与計算のための労働時間計算を、事務スタッフがクラウド上の計算サービスに、スタッフ15名分ほどを、１人１人手入力をし、入力間違いが起こっていました クラウドのサービス会社に問い合わせてみたところ、指定の列をもつCSV形式にして、一括インポートができることがわかりました で、まず各人のタイムカードの時刻から労働時間を自動計算するシートをわたしがつくり、全人の労働時間が出たので、あとは時給を掛けるだけでその月の支払い総額がわかるようにしました つまり全員の労働時間のシートを、同じ形にしました で、あまり詳しくないですが、マクロ（自動記録）で、各シートにある氏名と時間列のセル（具体的にはB2 G41 H41 J41 K41）を、画像のようなリストの形に流し込みたいと思いました しかし2行目（スタッフNo.0001番）は自動で入ったものの、3行目（スタッフNo.0002）以降の追加のコードがわかりません スタッフは月によって変動しだいたい13～MAXでも20名いるので、シート数は最大20はあります 【質問orお願い】 ・その月につくったスタッフ人数分のシートの総数を確認し、各労働時間（各シートのB2 G41 H41 J41 K41）を、画像のような列に入れ込むコードはどう書いたらよいでしょうか？ アイデアをいただきたい、または親切な方いましたらコード書いていただけると助かります 【回答上のご注意】 ・回答は解答（答え）を求めての投稿です ・昭和的な「あとは自分で考えろ」的なものは求めていません （登山の途中でいなくなる登山ガイドのようなものです） ・不明点あれば追加情報をお伝えします 動作の結果責任は問いませんのでよろしくお願いします

pdfが30件程度あります 開かず中身を確認する方法はありますか？プレビューだとパソコンが固まって中身を、すばやく確認できません

独学で、vbaを習得したいです！ ただ、きっかけは仕事が忙しく、とてもじゃないけど余裕が持てない。。 のが嫌すぎて、はじめました。 なので、無理やり作ってなんとか動かしてた、という感じで、最初に作ったのは途中で不具合が出たりして、全く身についてません。 本当に習得なんてほど遠く、業務中に、あ、これ効率化できるのでは？と閃いたら必死でvbaをネットで探して切り取りつぎはぎだらけ、本を見て繋いで、という感じです。最近はここに書けば答えてくださる優しい方を頼るだけで、ちょっと、あかんな、勉強せな、と思います。 私のマクロレベルは、1人で困難なく作れたのが、昨日の話ですが最終行まで、昇順に並べる、ぐらいかと思います。 難しすぎて、仕事を早く終わらせたい、という目的がなければ、やる気起きなかったです。本当にわけがわからない世界です。でも、すぐに、文を考え、希望のマクロを作れる人を尊敬します。 皆さんはどうやって学んだのですか？？ 参考に、させてください。 よろしくお願いします。

A列にリストがあり、C列のセル内に リストの5桁の数字があれば、C列にチェック（字を赤くするなど）が入り確認が可能になるマクロを組みたいです。下記はネットで探してきて、コピーして動かしたのですが、End ifに対するifがありませんが出て、その後Loopに対するForがありません、と出ました。 下記は合ってますか？ Sub Sample1() Dim i As Long, k As Long, myStr As String Dim myFound As Range, myFirst As Range For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row myStr = Cells(i, "A") Set myFound = Range("C:C").Find(what:=myStr, LookIn:=xlValues, lookat:=xlPart) If Not myFound Is Nothing Then Set myFirst = myFound GoTo 処理 Do Set myFound = Range("C:C").FindNext(after:=myFound) If myFound.Address = myFirst.Address Then Exit Do GoTo 処理 処理: For k = 1 To Len(myFound) If Mid(myFound, k, Len(myStr)) = myStr Then myFound.Characters(Start:=k, Length:=Len(myStr)).Font.ColorIndex = 3 End If Next k Loop End If Next i End Sub

VS2022で.NetFramework4.0を使いたいです。 https://qiita.com/diontools/items/b193ae8394161fc26698#net-framework-4--45-の場合 「ダウンロードした Nuget パッケージを .zip にリネームし、その中の /build/.NETFramework/ 以下を C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\ に上書きすることで配置完了です。」とありますが、具体的にリンク先のどのファイルをダウンロードすればよいのでしょうか。

Visualstudio2019(VisualBasic2019)を利用してシステム開発を行っております。 クリスタルレポート関連の参照設定についてはローカルへコピーしないよう設定しているのですが、ローカルにコピーされてしまいます。 何か設定に不備があるとは考えているのですが、分かる方がいらっしゃいましたらご教授頂けますと幸いです。 以上です。

質問時刻＝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