エクセルの学校：全文検索：Hyper Estraier：日付

Results of 1 - 1 of about 13168 for 日付 (0.003 sec.)

[[20181109152329]]: #score: 2423; @digest: 027cd030d745a8d62e7dbdf368838a23; @id: 77784; @mdate: 2018-11-27T09:41:21Z; @size: 47723; @type: text/plain; #keywords: 業ws (173756), 良● (171838), 理wb (126331), 出ws (121855), 県. (112230), 入:= (111319), 出マ (85354), 表_ (79292), 式挿 (70137), 業用 (57291), 用シ (51720), 城県 (35150), 理用 (34435), xlpasteformulas (32535), 用ブ (31305), xlfilldefault (27101), 茨城 (25958), 理表 (25621), 管理 (18530), selection (18311), autofill (16097), columns (15470), operation (14240), skipblanks (14037), ロブ (12905), pastespecial (12662), 作業 (11683), 値貼 (11648), xlpastevalues (11042), select (10994), マナ (10950), cutcopymode (9561); 『複数ブック複数シートのデータ抽出』（125）
お世話になっております。テレフォンアポイントの結果（当日分）を抜き出すマクロを考えております。電話をかけ終わった後、下記のように誰にかけて何を話したのか記録を残すようにしています。 sheet1には少しわかりずらいと思うのですが1つの会社ごとに10列設けており（例では5行にしています…）、A〜D列までは10行ごとに列で結合させています。 E列より1回の電話を掛けるごとに1行ずつ記入するようなしくみにしております。 sheet2はデータベースのようなフォーマットで、電話した会社の情報を表示させています。（管理表ブック_sheet1） A B C D E F G H I J K L M N O P 4 No 会社状況区分部署名前日付時間部署役職名前印象結果次回備考 AP 5 a ab 1/1 10:00 A 部長 D 良 ● 1/2 - - 6 a ab 1/2 14:00 V 課長 F 良 ● 1/4 - - 7 1 A社 ✓ 新規 n ac 1/4 16:00 V 課長 F 良 ● 1/8 - - 8 m ad 1/8 13:00 A G 良 ● - - - 9 ______________________________________ 10 a ab 1/2 10:00 X 部長 D 良 ● 1/31 - - 11 a ab 1/31 17:00 R - S 良 ● 2/5 - - 12 2 B社 ✓ 新規 e bb 2/5 11:00 X 部長 D 良 ● 2/8 - - 13 a ab 2/8 12:00 R - S 良 ● - - - （管理表ブック_sheet2） A B C D E F G H I 1 No 会社仮名拠点〒住所電話登録区分 2 1 A社 Aシャ A事務所 123-456 東京都***** 012-34** 1/2 新規 3 2 B社 Bシャ B事務所 123-579 東京都***** 012-11** 1/2 新規このようなブックが9つあります。そのうちの1ブックはほかのブックよりも1列多いフォーマットになっているため（E列に1行追加しています）、同じフォーマットのブックは8つになります。実現したいことは下記の通りです。セルのA1に日付を入力し、マクロを実行させると（例では1/2）該当の日付で電話を掛けた日（H列）が検索され、各ブックの各シートのから情報が抽出されるようにしたいです。抽出項目が各シートにまたがっており、なかなかうまく実行できません。（抽出マクロブック_sheet1） A B C D E F G H I J K L M N 1 1/2 3 No 会社拠点住所電話部署名前日付時間部署名前印象備考 AP 4 1 A社 A事務所東京都***** 012-34** a ab 1/2 14:00 V F 良 - - 5 2 B社 B事務所東京都***** 012-11** a ab 1/2 10:00 X D 良 - - 作成したマクロは下記の通りです。 "抽出マクロ"に転記したいのですが、・A1で指定した日付のデータが抽出されない（指定日付以外も抽出されてしまう）・抽出後の配置がばらばらという事象が起きています。尚、管理表ブックの日付は○月○日と表示するようにしているので、マクロで○/○の表示に変換しております。 Sub Macro1() Const cPATH = "C¥personal computer¥" Dim wk As Workbook Dim sh As Worksheet Dim tgtRow As Long Dim cFile As String Dim ws1 As Worksheet, x Application.ScreenUpdating = False With ThisWorkbook.Worksheets("sheet1") cFile = Dir(cPATH & "管理表*.xlsm") While cFile <> "" If Not cFile = (ThisWorkbook.Name & "管理表_フォーマット違分.xlsm") Then Set wk = Workbooks.Open(cPATH & cFile, False, True) For Each sh In wk.Worksheets tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 On Error Resume Next Columns("G:G").Select Selection.NumberFormatLocal = "yyyy/m/d" Range("E4:H4").Select Selection.AutoFilter sh.Range("$E$4:$H$4994").AutoFilter Field:=3, Criteria1:=Workbooks("抽出マクロ").Worksheets("sheet1").Range("A1").Value, Operator:=xlAnd .Range("A" & tgtRow).Resize(15, 1).Value = sh.Range("A5:A20").Value .Range("B" & tgtRow).Resize(15, 1).Value = sh.Range("B5:B20").Value .Range("C" & tgtRow).Resize(15, 1).Value = Sheets("sheet2").Range("B2:B20").Value .Range("D" & tgtRow).Resize(15, 1).Value = Sheets("sheet2").Range("F2:F20").Value .Range("E" & tgtRow).Resize(15, 1).Value = Sheets("sheet2").Range("G2:G20").Value .Range("F" & tgtRow).Resize(15, 1).Value = sh.Range("E5:E20").Value .Range("G" & tgtRow).Resize(15, 1).Value = sh.Range("F5:F20").Value .Range("H" & tgtRow).Resize(15, 1).Value = sh.Range("G5:G20").Value .Range("I" & tgtRow).Resize(15, 1).Value = sh.Range("H5:H20").Value .Range("J" & tgtRow).Resize(15, 1).Value = sh.Range("I5:I20").Value .Range("K" & tgtRow).Resize(15, 1).Value = sh.Range("K5:K20").Value .Range("L" & tgtRow).Resize(15, 1).Value = sh.Range("L5:L20").Value .Range("M" & tgtRow).Resize(15, 1).Value = sh.Range("O5:O20").Value .Range("N" & tgtRow).Resize(15, 1).Value = sh.Range("P5:P20").Value Application.CutCopyMode = False Selection.AutoFilter Columns("G:G").Select Selection.NumberFormatLocal = "m""月""d""日"";@" Next sh wk.Close False cFile = Dir End If Wend End With Application.ScreenUpdating = True End Sub 以上、ご指摘の程宜しくお願い致します。＜使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- 日付のオートフィルタは、↓のkanabunさんの回答を参考にするとよいです [[20150602132430]] 『オートフィルタで日付』（アイ）（マナ） 2018/11/09(金) 18:27 ---- こんな感じでどうでしょうか。結構、先は長そうですが、1つずつ考えていくと良いです。 1）管理表ブックのsheet2で1/2 データをオートフィルタ（フィルタオプション）で作業用シートに転記 2）転記された会社を1個ずつ、sheet1のB列から検索 3）検索された行のG列から下に10セルの範囲から、1/2を検索 4）検索された行のデータを作業用シートに転記 5）これを1）で転記された、すべての会社で繰り返す。 6）作業用シートから、抽出マクロブックのsheet1に転記 7）以上を、9個の管理用ブックで繰り返す（マナ） 2018/11/09(金) 19:21 ---- マナさんコメントありがとうございます。言葉足らずの説明で申し訳ないのですが、 sheet1のH列で日付を検索してデータを抽出したいのです。 sheet1で検索した企業をsheet2で検索するといったマクロにしたいのですが、希望通りの情報を抽出できるマクロになりませんでした。また、同フォーマットのブックは全部で8つ E列に1行追加されたフォーマット（E列の情報は抽出する必要なし）が1つです。以上、宜しくお願い致します。（125） 2018/11/10(土) 08:58 ---- ＞sheet1のH列で日付を検索してデータを抽出したいのです。 1）G列の間違いでしょうか? 2）sheet2のH列で検索してはなぜだめなのでしょうか? （マナ） 2018/11/10(土) 09:09 ---- マナさんすみません、G列の間違いです。 sheet2は電話を掛けた日ではなく、最初に電話をかけるために会社の情報を登録した日となっています。ユーザフォームで会社の住所・電話番号などを登録するようにしており、その情報がsheet2とsheet1のB列、D列に飛ぶようになっております。（125） 2018/11/10(土) 09:30 ---- 理解しました。では、sheet1データの右側O列以降は空いていますか。作業列として使用可能ですか。（マナ） 2018/11/10(土) 09:42 ---- マナさん抽出マクロブックのsheet1でしょうか? そちらのシートでしたらO列以降は何もデータが入っておりません。（125） 2018/11/10(土) 09:54 ---- もう一つ、sheet1で、F列とK列が同じ見出しになっています。どちらかを別の見出しにできませんか。そうするとフィルタオプションが使え楽になります。（マナ） 2018/11/10(土) 10:00 ---- マナさん名前は同じなのですが、 3行目でE〜H列まで、I〜L列までを結合して架電者と受電者で見出しをもう1つつけています。 A B C D E F G H I J K L M N O P 3 No|会社|状況|区分|______架電者____|______受電者____|結果|次回|備考|AP 4 | | | |部署名前日付時間 |部署役職名前印象分かりずくて申し訳ないのですが、 A〜DとM〜Pは3・4行目と結合、3行目のE〜HとI〜Lを結合しています。行全体にオートフィルターをかけるのは結合しているため難しいかと思いますので、私の作ったマクロではE〜Hのみにフィルターをかけています。後出し後出しで申し訳ございませんが、宜しくお願い致します。（125） 2018/11/10(土) 10:45 ---- 返事いただいていたのに気づいていませんでした。＞抽出マクロブックのsheet1でしょうか? 違います。管理用ブックのsheet1です。見出しについては理解しました。（マナ） 2018/11/10(土) 10:50 ---- ごめんなさい。 O列以降ではなく、Q列以降の間違いでした。（マナ） 2018/11/10(土) 10:52 ---- マナさん P列以降もQ・Rは入力規制のためのデータや数式が入っております。 S列以降でしたら、何もデータがない状態です。（125） 2018/11/10(土) 11:05 ---- たぶん、こんな感じでできると思いますので、考えてみてください。まずは、1つの管理用ブックについて、手作業で試してみてはどうでしょうか。マクロもいきなり完成形を目指す必要はありません。 1つずつ考えていくとよいです。 1）管理表ブックのsheet1のQ列に7列挿入 2）管理表ブックのsheet1の4行目をコピーし、5行目に挿入 3）heet1ののM3:P3を、M5:P5にコピー 4）sheet2のA1:G1をコピーし、Sheet1のQ5に貼り付け 5）Sheet1のO列6行目以下に数式挿入:=IF(a6="",Q5,a6) 6）Sheet1のp列以降も数式挿入:=Vlookup(Q6,sheet2!$a:$g,2,0) 7）Sheet1の1/2 データをフィルタオプションで作業用シートに転記 8）作業用シートから、抽出マクロブックのsheet1に転記 9）sheet1のQ〜W列を削除 10）sheet1の5行目を削除 11）以上を、9個の管理用ブックで繰り返す（マナ） 2018/11/10(土) 11:17 ---- ↑5行目に用意したフィルターオプション用の見出しで、 K列は、別の別の見出しに修正する作業が必要でした。（マナ） 2018/11/10(土) 11:23 ---- マナさん上記の方法を試してみました。 1つ伝え漏れていたことがありまして、管理ブックのsheet1のP列なのですが、 A列〜D列同様に10行ごとに結合してあります。 5）・6）の内容ですが、O・P列ともに抽出したい情報なので関数を入れてしまうと情報が全て関数結果になってしまいます。私が試した方法でsheet1のE〜H列の4行目にオートフィルタを入れ日付を抽出するやり方でしたら、該当日付のデータが1行ずつ検索され、思い通りの内容になったのでその状態から、欲しい項目だけを抜き出すというのが課題なのかなと自分なりに思っております。恐らくマナさんのやり方は見出しを設定しなおすことと、1シートに情報をまとめて一気に情報を吸い取るやり方なのではないかと推測しております（違っていたらすみません）。そうできれば一番良いのですが、sheet1とsheet2の行単位の塊が違うため（sheet1は10行で1企業 sheet2は1行1企業）、なかなかそこをマッチさせることが難しいです・・・。（125） 2018/11/10(土) 11:52 ---- このような感じです。（管理表ブック_sheet1） A B C D E F G H I J K L M N O P 4 No 会社状況区分部署名前日付時間部署役職名前印象結果次回備考 AP 5 a ab 1/1 10:00 A 部長 D 良 ● 1/2 - 6 a ab 1/2 14:00 V 課長 F 良 ● 1/4 - 7 1 A社 ✓ 新規 n ac 1/4 16:00 V 課長 F 良 ● 1/8 - */* 8 m ad 1/8 13:00 A G 良 ● - - 9 ______________________________________ 10 a ab 1/2 10:00 X 部長 D 良 ● 1/31 - 11 a ab 1/31 17:00 R - S 良 ● 2/5 - 12 2 B社 ✓ 新規 e bb 2/5 11:00 X 部長 D 良 ● 2/8 - */* 13 a ab 2/8 12:00 R - S 良 ● - （125） 2018/11/10(土) 11:55 ---- ＞5）Sheet1のO列6行目以下に数式挿入:=IF(a6="",Q5,a6) ＞6）Sheet1のp列以降も数式挿入:=Vlookup(Q6,sheet2!$a:$g,2,0) 間違えました 5）Sheet1のQ列6行目以下に数式挿入:=IF(a6="",Q5,a6) 6）Sheet1のR列以降も数式挿入:=Vlookup(Q6,sheet2!$a:$g,2,0) です。（マナ） 2018/11/10(土) 12:02 ---- P列も結合セルなら A列と同じように、↓数式で対応するとよいです。＞5）Sheet1のQ列6行目以下に数式挿入:=IF(a6="",Q5,a6) （マナ） 2018/11/10(土) 12:14 ---- マナさんご連絡が遅くなってしまい、申し訳ございません。マナさんの方法で一先ず1ブックのみマクロを記録させてみました。この方法で正常にコピペはできたのですが、処理速度が遅くいのです(泣) 管理ブックのsheet1は5000行ほどあり、チェックボックスが1000個程入っているためブックを開くこと自体重いのですが、7列挿入するところにかなりの時間を要してしまい、これを残り8ブックするとなると、少し時間がかかりすぎてしまうのかなと思っております。挿入以外で何か方法がありましたらご教授いただきたいです。（125） 2018/11/12(月) 10:55 ---- ＞7列挿入するところにかなりの時間を要してしまいでは。手作業で、↓ここの時間はどうですか? ＞4）sheet2のA1:G1をコピーし、Sheet1のQ5に貼り付け（マナ） 2018/11/12(月) 18:39 ---- こんな手順ではどうですか。今回も、まずは手作業で。 1)管理用ブックを開く 2)作業用シート追加 3)管理用ブックのsheet1のA〜P列をコピー 4)作業用シートに値貼り付け 5)作業用シートのM,N列削除 6)作業用シートのJ列削除 7)作業用シートのE列に列挿入 8)業用シートの2行目を行削除 9)作業用シートのO列2行目以下に数式挿入:=IF(mod(row()-1,10)=1,N2,O1) 10)作業用シートのO列をコピーし、そのまま値貼り付け 11)作業用シートのN列を削除 12)作業用シートのA、B列の空白セルをジャンプ機能で選択 13)上記範囲に、数式挿入:=A2 14)作業用シートA、B列をコピーし、そのまま値貼り付け 15)作業用シートのオートフィルタ—で、1/2以外を抽出 16)抽出された行を削除 17)作業用シートのC、D列に数式入力:=Vlookup(A1,sheet2!$a:$g,4,0) 18)作業用シートのE列に数式入力:=Vlookup(A1,sheet2!$a:$g,7,0) 19)見出し以外をコピーし、抽出用シートの最下行の下に値貼り付け 20)管理用ブックを保存しないで閉じる 21)以上をすべての管理用ブックで、繰り返す（マナ） 2018/11/12(月) 20:40 ---- マナさんお返事ありがとうございます。＞では。手作業で、↓ここの時間はどうですか? 1行の貼り付けであればスムーズに行えます。上記の方法ためしてみました。 9)の数式を理解できていないのですが、数式をあてはめたところすべての列で0となってしまいます。 12)結合セルのせいなのか、ジャンプ機能（ctrl+↓）が使えませんでした。 17)18)sheet1は10行単位、sheet2は1行単位での構成のためオートフィルをすると情報が出てくる行と、エラーになってしまう行があります。お手数おかけしますが、宜しくお願い致します。（125） 2018/11/13(火) 11:33 ---- 手順を修正です＞8)業用シートの2行目を行削除 ↓ 8)作業用シートの4行目を削除後、1〜2行目を削除＞12)結合セルのせいなのか、ジャンプ機能（ctrl+↓）が使えませんでした。作業用シートに値貼り付けしていたら、結合は解除されているはずです。必ず、順番にすべて実行してください。（マナ） 2018/11/13(火) 18:03 ---- マナさん値貼り付けを抜かしていました。以下の通りマクロの記録機能で作ってみました。 O列の数式なのですが、表示形式を日付にすると数式結果が0や1の箇所が1/1等となってしまうのですが改善方法はありますでしょうか? 尚(13はジャンプ機能を使うのを忘れてしまいました、すみません。 9行ごとにオートフィルをしました。 Sub Macro3() Windows("管理用.xlsm").Activate Columns("A:P").Select '(3 Selection.Copy Sheets.Add After:=Sheets(Sheets.Count) Columns("A:P").Select '(4 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("M:N").Select '(5 Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Columns("J:J").Select '(6 Selection.Delete Shift:=xlToLeft Columns("E:E").Select '(7 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove Rows("4:4").Select Range("C4").Activate '(8 Selection.Delete Shift:=xlUp Rows("1:2").Select Range("C1").Activate Selection.Delete Shift:=xlUp Range("O2").Select '(9 ActiveCell.FormulaR1C1 = "=IF(MOD(ROW()-1,10)=1,RC[-1],1)" Range("O2").Select Selection.AutoFill Destination:=Range("O2:O2381"), Type:=xlFillDefault Range("O2:O2381").Select Columns("O:O").Select '(10 Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("N:N").Select '(11 Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range("A2:B2").Select '(13 Selection.End(xlDown).Select Range("A3").Select ActiveCell.FormulaR1C1 = "=R[-1]C" Range("A3").Select Selection.AutoFill Destination:=Range("A3:B3"), Type:=xlFillDefault Range("A3:B3").Select Selection.AutoFill Destination:=Range("A3:B11"), Type:=xlFillDefault Range("A3:B11").Select Range("A11:B11").Select Selection.Copy Range("A13:B13").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A13:B21"), Type:=xlFillDefault Range("A13:B21").Select Range("A19:B19").Select Selection.Copy Range("A23:B23").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("B24").Select Application.CutCopyMode = False Range("A23:B23").Select Selection.AutoFill Destination:=Range("A23:B31"), Type:=xlFillDefault Range("A23:B31").Select Range("A31:B31").Select Selection.Copy Range("A33:B33").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A33:B41").Select Range("A41:B41").Select Selection.Copy Range("A43:B43").Select Range("A31:B31").Select Application.CutCopyMode = False Selection.Copy Range("A33:B33").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A33:B41"), Type:=xlFillDefault Range("A33:B41").Select Range("A41:B41").Select Selection.Copy Range("A43:B43").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A43:B51"), Type:=xlFillDefault Range("A43:B51").Select Range("A52:B52").Select Selection.Copy Range("A53:B53").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A51:B51").Select Application.CutCopyMode = False Selection.Copy Range("A53:B53").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A53:B61"), Type:=xlFillDefault Range("A53:B61").Select Range("A62:B62").Select Selection.Copy Range("A63").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A63:B63").Select Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A63:B71"), Type:=xlFillDefault Range("A63:B71").Select Range("A61:B61").Select Selection.Copy Range("A63:B63").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A63:B71"), Type:=xlFillDefault Range("A63:B71").Select Range("A71:B71").Select Selection.Copy Range("A73").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A73:B81"), Type:=xlFillDefault Range("A73:B81").Select Range("A81:B81").Select Selection.Copy Range("A83:B83").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A83:B91"), Type:=xlFillDefault Range("A83:B91").Select Range("A91:B91").Select Selection.Copy Range("A93:B93").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A93:B101"), Type:=xlFillDefault Range("A93:B101").Select Range("A101:B101").Select Selection.Copy Range("A103:B103").Select Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Selection.AutoFill Destination:=Range("A103:B111"), Type:=xlFillDefault Range("A103:B111").Select '繰り返しのため割愛 Columns("A:B").Select '(14 Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Rows("1:1").Select '(15 Selection.AutoFilter ActiveSheet.Range("$A$1:$Q$542").AutoFilter Field:=8, Criteria1:=Array("=") _ , Operator:=xlFilterValues, Criteria2:=Array(1, "5/16/2018", 1, "7/19/2018", 1, _ "8/2/2018", 2, "10/17/2018", 2, "10/18/2018", 2, "10/22/2018", 2, "10/31/2018", 1, _ "11/12/2018") Rows("1:2381").Select '(16 Selection.Delete Shift:=xlUp Range("C1").Select '(17 ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],sheet2!C1:C7,4,0)" Range("C1").Select Selection.AutoFill Destination:=Range("C1:C7"), Type:=xlFillDefault Range("C1:C7").Select Columns("B:B").EntireColumn.AutoFit Range("D1").Select '(17 ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],sheet2!C1:C7,6,0)" Range("D1").Select Selection.AutoFill Destination:=Range("D1:D7"), Type:=xlFillDefault Range("D1:D7").Select Range("E1").Select '(18 ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],sheet2!C1:C7,7,0)" Range("E1").Select Selection.AutoFill Destination:=Range("E1:E7"), Type:=xlFillDefault Range("E1:E7").Select Range("A2:N7").Select Selection.Copy Windows("抽出マクロ.xlsm").Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A4").Select Windows("管理用.xlsm").Close End Sub （125） 2018/11/14(水) 11:45 ---- O列の式を＞=IF(mod(row()-1,10)=1,N2,O1) ↓ =IF(mod(row()-1,10)=1,If(N2=""."".N2,O1) で、試してください。まずは、手作業で。今は、マクロの記録は不要です。手作業でできることを確認してからです。（マナ） 2018/11/14(水) 18:45 ---- ＞ジャンプ機能（ctrl+↓）違います。 https://excelkamiwaza.com/kuuhaku_umeru.html （マナ） 2018/11/14(水) 19:02 ---- マナさんジャンプ機能のURLご丁寧にありがとうございます。 =A2ですべての行にA〜B列の情報を反映できました。 =IF(mod(row()-1,10)=1,If(N2=""."".N2,O1) のしきですが、入力すると「この関数に対して、多すぎる引数が入力されています」とエラーがでてしまいました。 =IF(MOD(ROW()-1,10)=1,IF(N2="","",N2)) の式で試してみたのですが、N列に日付が入力されている行はO列にも反映されましたがそれ以外の行はFALSEとでてしまいました。。。（125） 2018/11/15(木) 14:28 ---- マナさんの書いた式で)が一つ足りないようだ。 =IF(MOD(ROW()-1,10)=1,IF(N2="","",N2),O1) （ねむねむ） 2018/11/15(木) 14:38 ---- あと式を掲示板にあげるときにはなるべく数式バーの式をコピーして掲示板に張り付けるようにしてくれ。今回の =IF(mod(row()-1,10)=1,If(N2=""."".N2,O1) でも,（カンマ）が.(ピリオド）になっているのでEXCEL上の数式から間違っているのか、掲示板に書き込む際に間違えたのか判断がつかなくなる（ねむねむ） 2018/11/15(木) 14:41 ---- ねむねむさん数式のご指摘ありがとうございます。無事、反映されました。数式はカンマに直したのですが、こちらに貼った数式はピリオドのままでした。誤解を招いてしまい、申し訳ございませんでした。（125） 2018/11/15(木) 14:49 ---- 手作業では、期待する結果になりましたか。それとも、まだ異なる点がありますか。もし期待通りであれば、以下について教えてください。＞そのうちの1ブックはほかのブックよりも1列多いフォーマットになっているためこれが理解できていません。 1列多い管理表ブックでは、上記手順のどこを変更する必要がありますか。（マナ） 2018/11/15(木) 19:54 ---- マナさんお世話になっております。おかげさまで求めている形になりました。違うフォーマットの件ですが、下記のようなフォーマットになっております。（管理表ブック_sheet1） A B C D E F G H I J K L M N O P 4 No 会社状況区分地域部署名前日付時間部署役職名前印象結果次回備考 AP 5 a ab 1/1 10:00 A 部長 D 良 ● 1/2 - - 6 a ab 1/2 14:00 V 課長 F 良 ● 1/4 - - 7 1 A社 ? 新規 ff n ac 1/4 16:00 V 課長 F 良 ● 1/8 - - 8 m ad 1/8 13:00 A G 良 ● - - - 9 ______________________________________ 10 a ab 1/2 10:00 X 部長 D 良 ● 1/31 - - 11 a ab 1/31 17:00 R - S 良 ● 2/5 - - 12 2 B社 ? 新規 gg e bb 2/5 11:00 X 部長 D 良 ● 2/8 - - 13 a ab 2/8 12:00 R - S 良 ● - - - 管理表ブックsheet2のフォーマットは全ブック同じです。また、抽出ブックにもEの情報を拾う必要はありません。以上、宜しくお願い致します。（125） 2018/11/16(金) 10:26 ---- E列が挿入されただけで順番は同じ表ということですね。 1）9つの管理表ブックは1つの同じフォルダに保存されているのでしょうか 2）1列多い管理表ブックも同じフォルダでしょうか 3）抽出マクロブックも同じフォルダでしょうか 4）どれが1列多いブックか、ブックを開かないとわからのでしょうか（マナ） 2018/11/17(土) 08:21 ---- マナさんお世話になっております。 1）、2）、3）すべて同じフォルダに格納されております 4）ブックの名前が全て違いますので、区別はできます。以上、宜しくお願い致します。（125） 2018/11/19(月) 10:15 ---- ＞4）ブックの名前が全て違いますので、区別はできます。具体的に、説明していただけますか。名前のルールが決まっていると、マクロで判断させることができます。（マナ） 2018/11/19(月) 18:31 ---- マナさんブックは都道府県別になっています。ブック名は『管理表_●●県.xlsm』のルールで作成されております。ちなみに1列多い行のブックは『管理表_茨城県.xlsm』です。以上、宜しくお願い致します。（125） 2018/11/20(火) 16:42 ---- では、こんな手順でできそうです手順でわからないことはありますか理解できたなら、これをマクロにしていきます 1)指定フォルダ内のファイルで、「管理表_*.xlsm」（管理用ブック）を開き 2)作業用シート追加 3)管理用ブックのsheet1のA〜Q列をコピー 4)作業用シートに値貼り付け 5)「管理表_茨城県.xlsm」以外ならば、作業用シートのE列を挿入、R列削除 6)作業用シートのM,N列削除 7)作業用シートのJ列削除 8)業用シートの4行目を行削除 9)業用シートの1,2行目を行削除 10)作業用シートのO列2行目以下に数式挿入:=IF(mod(row()-1,10)=1,IF(N2="","",N2),O1) 11)作業用シートのO列をコピーし、そのまま値貼り付け 12)作業用シートのO列を削除 13)作業用シートのA、B列の空白セルをジャンプ機能で選択 14)上記範囲に、数式挿入:=A2 15)作業用シートA、B列をコピーし、そのまま値貼り付け 16)作業用シートのオートフィルタ—で、1/2以外を抽出 17)抽出された行を削除 18)作業用シートのC、D列に数式入力:=Vlookup(A1,sheet2!$a:$g,4,0) 19)作業用シートのE列に数式入力:=Vlookup(A1,sheet2!$a:$g,7,0) 20)見出し以外をコピーし、抽出マクロブックのsheet1の最下行の下に値貼り付け 21)管理用ブックを保存しないで閉じる 22)以上をすべての「管理表_*.xlsm」で、繰り返す（マナ） 2018/11/20(火) 20:27 ---- マナさんお世話になっております。手順のご説明丁寧にありがとうございます。下記のようにマクロの記録をしてみた(ここでは10/4以外で記録)のですが、知識不足故に分からない点がありますのでご教示願います。 1)フォルダ内のブックを順次開いていくマクロがわかりません。 5)「管理表_茨城県.xlsm」以外ならばとブック名で判断させるマクロはどのようなマクロでしょうか。 22)繰り返しはFor Nextなどを使うのでしょうか? 上記手順以外で、質問なのですが指定日付の値（下記マクロでは10/4）を抽出マクロブックのA1に入力された値にしたいのですが、どのように代入すればいいでしょうか? Sub Macro4() Sheets.Add After:=Sheets(Sheets.Count) Sheets("sheet1").Select Columns("A:P").Select Selection.Copy Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("E:E").Select Application.CutCopyMode = False Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove Columns("N:O").Select Selection.Delete Shift:=xlToLeft Columns("K:K").Select Selection.Delete Shift:=xlToLeft Rows("4:4").Select Selection.Delete Shift:=xlUp Rows("1:2").Select Selection.Delete Shift:=xlUp Range("O2").Select ActiveCell.FormulaR1C1 = _ "=IF(MOD(ROW()-1,10)=1,IF(RC[-1]="""","""",RC[-1]),R[-1]C)" Range("O2").Select Selection.AutoFill Destination:=Range("O2:O1782"), Type:=xlFillDefault Range("O2:O1782").Select Selection.NumberFormatLocal = "m""月""d""日"";@" Columns("H:H").Select Selection.NumberFormatLocal = "m""月""d""日"";@" Columns("I:I").Select Selection.NumberFormatLocal = "h:mm;@" Columns("N:N").Select Columns("O:O").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("N:N").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Columns("A:B").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" Columns("A:B").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Rows("1:1").Select Application.CutCopyMode = False Selection.AutoFilter ActiveSheet.Range("$A$1:$Q$4994").AutoFilter Field:=8, Criteria1:=Array("<>10/4") Rows("2:4994").Select Selection.Delete Shift:=xlUp Selection.AutoFilter Range("C1").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],sheet2!C1:C7,4,0)" Range("D1").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],sheet2!C1:C7,6,0)" Range("E1").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],sheet2!C1:C7,7,0)" Range("C1:E1").Select Selection.AutoFill Destination:=Range("C1:E3"), Type:=xlFillDefault Range("A2:N3").Select Selection.Copy Windows("抽出マクロ.xlsm").Activate Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveWindow.Close End Sub お手数おかけしますが、宜しくお願い致します。（125） 2018/11/21(水) 15:49 ---- まずは、管理表_茨城県.xlsmの場合だけを考えます。動作確認していませんが手順2)〜20)は、こんな感じでできるはずです。 Option Explicit Sub test() Dim 抽出Ws As Worksheet Dim 管理Wb As Workbook Dim 作業Ws As Worksheet Dim 日付 As Long Dim tbl As Range Set 抽出Ws = ThisWorkbook.Worksheets("Sheet1") 日付 = 抽出Ws.Range("A1").Value2 Set 管理Wb = Workbooks("管理表_茨城県.xlsm") Set 作業Ws = Worksheets.Add(before:=管理Wb.Worksheets(1)) With 作業Ws 管理Wb.Worksheets("Sheet1").Columns("A:Q").Copy .Range("A1").PasteSpecial Paste:=xlPasteValues .Columns("M:N").Delete .Columns("J").Delete .Columns("E").Insert .Rows(4).Delete .Rows("1:2").Delete Set tbl = .Range("A1:N1").CurrentRegion End With With Intersect(tbl, tbl.Offset(1)) .Columns("O").Formula = "=IF(MOD(ROW()-1,10)=1,IF(N2="""","""",N2),O1)" .Columns("O").Value = Columns("O").Value .Columns("N").EntireColumn.Delete .Columns("A:B").SpecialCells(xlCellTypeBlanks).Formula = "=A2" .Columns("A:B").Value = .Columns("A:B").Value End With With 作業Ws.Range("A1:N1").CurrentRegion .AutoFilter Field:=8, Criteria1:=">" & 日付, Operator:=xlOr, Criteria2:="<" & 日付 .EntireRow.Delete End With With 作業Ws.Range("A1:N1").CurrentRegion .Columns("C:D").Formula = "=Vlookup(A1,sheet2!$a:$g,4,0)" .Columns("E").Formula = "=Vlookup(A1,sheet2!$a:$g,7,0)" .Copy 抽出Ws.Range("A" & Rows.Count).End(xlUp).PasteSpecial Paste:=xlPasteValues End With End Sub （マナ） 2018/11/21(水) 19:13 ---- ＞20)見出し以外をコピーし、抽出マクロブックのsheet1の最下行の下に値貼り付け見出しは、手順17）で削除してしまえばよいので、全データをコピーで良かったです。（マナ） 2018/11/21(水) 19:19 ---- マナさんお世話になっております。マクロのほうありがとうございます。頂いたマクロを実行してみたのですが、質問がいくつかありますのでご教示願います。 Option Explicit Sub test() Dim 抽出Ws As Worksheet Dim 管理Wb As Workbook Dim 作業Ws As Worksheet Dim 日付 As Long Dim tbl As Range Set 抽出Ws = ThisWorkbook.Worksheets("Sheet1") 日付 = 抽出Ws.Range("A1").Value2 Set 管理Wb = Workbooks("管理表_茨城県.xlsm") Set 作業Ws = Worksheets.Add(before:=管理Wb.Worksheets(1)) With 作業Ws 管理Wb.Worksheets("sheet1").Columns("A:Q").Copy .Range("A1").PasteSpecial Paste:=xlPasteValues .Columns("N:O").Delete .Columns("K").Delete .Rows(4).Delete .Rows("1:2").Delete Set tbl = .Range("A1:N1").CurrentRegion End With With Intersect(tbl, tbl.Offset(1)) .Range("O1:O4994").FormulaR1C1 = "=IF(MOD(ROW()-1,10)=1,IF(RC[-1]="""","""",RC[-1]),R[-1]C)" .Range("O1:O4994") = Range("O1:O4994").Value .Columns("N").EntireColumn.Delete End With Columns("A:B").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" Range("A:B") = Range("A:B").Value '*********************************ここから下******************************************** With 作業Ws.Range("A1:N1").CurrentRegion .AutoFilter Field:=8, Criteria1:=">" & 日付, Operator:=xlOr, Criteria2:="<" & 日付 .EntireRow.Delete End With With 作業Ws.Range("A1:N1").CurrentRegion .Columns("C:D").Formula = "=Vlookup(A1,sheet2!$a:$g,4,0)" .Columns("E").Formula = "=Vlookup(A1,sheet2!$a:$g,7,0)" .Copy 抽出Ws.Range("A" & Rows.Count).End(xlUp).PasteSpecial Paste:=xlPasteValues End With 上記が実行後、訂正したマクロなのですが ***ここから下***の部分がエラーが出て実行できませんでした。（改善のマクロもわかりませんでした）オブジェクト変数または With ブロック変数が設定されていません。(Error 91)とエラーが出ます。また、作業用シートが抽出マクロブックの先頭に作成されるのですが、私の認識だと管理用ブックの最後尾にシートが作成されると思っていたのですが、ただの認識間違いでしょうか? 至らない質問ばかりで申し訳ございませんが、何卒宜しくお願い致します。（125） 2018/11/22(木) 11:44 ---- 始めからステップインしなおしたのですが、 withのエラーが出ませんでした（上記は私のやり方が悪かったようです…）。しかし、抽出した結果が求めたい抽出マクロブックのsheet1のA1の値ではなかったこととオートフィルの後、行を削除するとAB列の値が全て残っており、そのほかの列のもまばらに値が残っています。何か改善策はありますでしょうか? 度々申し訳ございませんが、宜しくお願い致します。（125） 2018/11/22(木) 11:59 ---- 手順を修正しました頭の中で考えているだけなので、まだ列を間違えているかもしれません。 1)抽出マクロブックのsheet1のA1の値を、変数「日付」に代入 2)指定フォルダ内のファイルで、「管理表_*.xlsm」（管理用ブック）を開き 3)作業用シート追加 4)管理用ブックのsheet1のA〜Q列をコピー 5)作業用シートに値貼り付け 6)「管理表_茨城県.xlsm」以外ならば、作業用シートのE列を挿入、R列削除 7)作業用シートのn,o列削除 8)作業用シートのk列削除 9)業用シートの4行目を行削除 10)業用シートの1,2行目を行削除 11)作業用シートのO列2行目以下に数式挿入:=IF(mod(row()-1,10)=1,IF(N2="","",N2),O1) 12)作業用シートのO列をコピーし、そのまま値貼り付け 13)作業用シートのN列を削除 14)作業用シートのA、B列の空白セルをジャンプ機能で選択 15)上記範囲に、数式挿入:=A2 16)作業用シートA、B列をコピーし、そのまま値貼り付け 17)作業用シートのオートフィルタ—で、1）の日付より前または1）の日付より後を抽出 18)抽出された行を削除 19)作業用シートのC、D列に数式入力:=Vlookup(A1,sheet2!$a:$g,4,0) 20)作業用シートのE列に数式入力:=Vlookup(A1,sheet2!$a:$g,7,0) 21)作業用シートのデータをコピーし、抽出マクロブックのsheet1の最下行の下に値貼り付け 22)管理用ブックを保存しないで閉じる 23)以上をすべての「管理表_*.xlsm」で、繰り返す Sub test2() Dim 抽出Ws As Worksheet Dim 管理Wb As Workbook Dim 作業Ws As Worksheet Dim 日付 As Long Dim tbl As Range Set 抽出Ws = ThisWorkbook.Worksheets("Sheet1") 日付 = 抽出Ws.Range("A1").Value2 Set 管理Wb = Workbooks("管理表_茨城県.xlsm") Set 作業Ws = Worksheets.Add(before:=管理Wb.Worksheets(1)) With 作業Ws 管理Wb.Worksheets("Sheet1").Columns("A:Q").Copy .Range("A1").PasteSpecial Paste:=xlPasteValues .Columns("n:o").Delete .Columns("k").Delete .Rows(4).Delete .Rows("1:2").Delete Set tbl = .Range("A1:N1").CurrentRegion End With With Intersect(tbl, tbl.Offset(1)) .Columns("O").Formula = "=IF(MOD(ROW()-1,10)=1,IF(N2="""","""",N2),O1)" .Columns("O").Value = .Columns("O").Value .Columns("n").EntireColumn.Delete .Columns("A:B").SpecialCells(xlCellTypeBlanks).Formula = "=A2" .Columns("A:B").Value = .Columns("A:B").Value End With With 作業Ws.Range("A1:N1").CurrentRegion .AutoFilter Field:=8, Criteria1:=">" & 日付, Operator:=xlOr, Criteria2:="<" & 日付 .EntireRow.Delete End With With 作業Ws.Range("A1:N1").CurrentRegion .Columns("C:D").Formula = "=Vlookup(A1,sheet2!$a:$g,4,0)" .Columns("E").Formula = "=Vlookup(A1,sheet2!$a:$g,7,0)" .Copy 抽出Ws.Range("A" & Rows.Count).End(xlUp).PasteSpecial Paste:=xlPasteValues End With End Sub （マナ） 2018/11/22(木) 18:54 ---- ＞また、作業用シートが抽出マクロブックの先頭に作成されるのですが、＞私の認識だと管理用ブックの最後尾にシートが作成されると思っていたのですが http://hensa40.cutegirl.jp/archives/705 ＞Set 作業Ws = Worksheets.Add(before:=管理Wb.Worksheets(1)) ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ 最後尾に作成したいなら Set 作業Ws = Worksheets.Add(after:=管理Wb.Sheets(Sheets.Count) でも、どうせ、手順22)で、保存しないで閉じるので、今回は、位置はどこでもよいです。（マナ） 2018/11/22(木) 19:36 ---- マナさんお世話になっております。お返事が遅くなてしまい、申し訳ございません。頂いたマクロを参考に自分でも作ってみましたが、やはりオートフィルターがうまく作動しません。事象としては・吸い上げたい日付が吸い上がらないこと・行を削除するとA〜E列とH列以外が削除されてしまうことです。＞でも、どうせ、手順22)で、保存しないで閉じるので、位置ではなく抽出ブックに作業シートが追加されてしまうことが問題だと思ったのですが、管理ブックをアクティブにするとこの問題は解決しました。お騒がせして申し訳ございませんでした。 Sub original() Dim 管理WB As Workbook Dim 抽出WS As Worksheet Dim 作業WS As Worksheet Dim 日付 As Long Dim RNG As Range Dim myPath As String Dim myFile As String Application.ScreenUpdating = False myPath = "C:¥¥" myFile = Dir(myPath & "管理表*.xlsm") '抽出マクロブックのsheet1のA1の値を変数「日付」に代入 Set 抽出WS = Workbooks("抽出マクロ.xlsm").Worksheets("sheet1") 日付 = 抽出WS.Range("A1").Value2 Set 管理WB = ActiveWorkbook Do Until myFile = "" '指定フォルダ内のファイルで、「管理表_*.xlsm」（管理用ブック）を開く Workbooks.Open myPath & myFile '作業用シート追加 Set 作業WS = Sheets.Add(before:=管理WB.Sheets(1)) '「管理表_茨城県.xlsm」ならば、A〜Q列をコピー If 管理WB.Name = "管理表_茨城県.xlsm" Then Sheets("アポイント管理").Columns("A:Q").Copy 作業WS.Range("A1").PasteSpecial Paste:=xlPasteValues 作業WS.Columns("E").Delete Else '「管理表_茨城県.xlsm」以外ならば、A〜R列をコピー Sheets("sheet1").Columns("A:R").Copy 作業WS.Range("A1").PasteSpecial Paste:=xlPasteValues End If With 作業WS Set RNG = .Range("A1:N" & Cells(Rows.Count, "N").End(xlUp).Row) '作業用シートのE列を削除 Columns("E").Insert '作業用シートのN,O列削除 .Columns("N:O").Delete '作業用シートのK列削除 .Columns("K").Delete '作業用シートの4行目を行削除 .Rows(4).Delete '作業用シートの1,2行目を行削除 .Rows("1:2").Delete '作業用シートのO列2行目以下に数式挿入:=IF(mod(row()-1,10)=1,IF(N2="","",N2),O1) .Range("O2:O4994").FormulaR1C1 = "=IF(MOD(ROW()-1,10)=1,IF(RC[-1]="""","""",RC[-1]),R[-1]C)" '作業用シートのO列をコピーし、そのまま値貼り付け .Columns("O").Value = .Columns("O").Value '作業用シートのN列を削除 .Columns("N").Delete '作業用シートのA、B列の空白セルをジャンプ機能で選択 .Columns("A:B").Select Selection.SpecialCells(xlCellTypeBlanks).Select '上記範囲に、数式挿入:=A2 Selection.Formula = "=A2" '作業用シートA、B列をコピーし、そのまま値貼り付け .Columns("A:B").Value = .Columns("A:B").Value '作業用シートのオートフィルタ—で1)の日付より前、且つ1)の日付より後を抽出 .Rows(1).Select Selection.AutoFilter Field:=8, Criteria1:=">" & 日付, Operator:=xlOr, Criteria2:="<" & 日付 '作業用シートのC、D列に数式入力:=Vlookup(A1,sheet2!$a:$g,4,0) .Columns(3).Formula = "=Vlookup(A1,sheet2!$A:$G,4,0)" .Columns(4).Formula = "=Vlookup(A1,sheet2!$A:$G,6,0)" '作業用シートのE列に数式入力:=Vlookup(A1,sheet2!$a:$g,7,0) .Columns(5).Formula = "=Vlookup(A1,sheet2!$A:$G,7,0)" End With '作業用シートのデータをコピーし、抽出マクロブックのsheet1の最下行の下に値貼り付け RNG.Copy 抽出WS.Range("A" & LstRow2).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '管理用ブックを保存しないで閉じる ActiveWorkbook.Close False '以上をすべての「管理表_*.xlsm」で、繰り返す myFile = Dir() Loop Application.ScreenUpdating = True End Sub 以上、お忙しいところ恐れ入りますが宜しくお願い致します。（125） 2018/11/26(月) 17:16 ---- ＞'「管理表_茨城県.xlsm」以外ならば、A〜R列をコピー＞Sheets("sheet1").Columns("A:R").Copy A〜Pの間違いでした。申し訳ございません。（125） 2018/11/26(月) 17:20 ---- まずは、「管理表_茨城県.xlsm」で、 2018/11/22(木) 18:54の手順で問題ないか確認してください。間違いがあれば、それを修正してください。（マナ） 2018/11/26(月) 19:08 ---- マナさんお世話になっております。無事マクロを完成させることができました。 2)・6)の手順が「管理表_茨城県.xlsm」のシートのみで作るのは難しかったので一気に盛り込んでそこから手直しをしていきました^^; 各ブックが重いことと相まって、作ったマクロの動作が遅く（特に手順14が重いです）作業終了までに5分以上かかってしまいます。次はその改善をしたいと思います。長期に渡り、アドバイス頂き本当にありがとうございました。 Sub original() Dim 管理WB As Workbook Dim 抽出WS As Worksheet Dim 作業WS As Worksheet Dim 日付 As Long Dim RNG As Range Dim myPath As String Dim myFile As String Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlManual myPath = "C:¥¥" myFile = Dir(myPath & "管理表*.xlsm") '抽出マクロブックのsheet1のA1の値を変数「日付」に代入 Set 抽出WS = Workbooks("抽出マクロ.xlsm").Worksheets("sheet1") 日付 = 抽出WS.Range("C1").Value2 Set 管理WB = ActiveWorkbook Do Until myFile = "" '指定フォルダ内のファイルで、「管理表_*.xlsm」（管理用ブック）を開く Workbooks.Open myPath & myFile '作業用シート追加 Set 作業WS = Sheets.Add(before:=管理WB.Sheets(1)) '「管理表_茨城県.xlsm」ならば、A〜Q列をコピー If 管理WB.Name = "管理表_茨城県.xlsm" Then Sheets("sheet1").Columns("A:Q").Copy 作業WS.Range("A1").PasteSpecial Paste:=xlPasteValues 作業WS.Columns("E").Delete Else '「管理表_茨城県.xlsm」以外ならば、A〜P列をコピー Sheets("sheet1").Columns("A:P").Copy 作業WS.Range("A1").PasteSpecial Paste:=xlPasteValues End If With 作業WS Set RNG = .Range("A1:N" & Cells(Rows.Count, "N").End(xlUp).Row) '作業用シートのE列を削除 Columns("E").Insert '作業用シートのN,O列削除 .Columns("N:O").Delete '作業用シートのK列削除 .Columns("K").Delete '作業用シートの4行目を行削除 .Rows(4).Delete '作業用シートの1,2行目を行削除 .Rows("1:2").Delete '作業用シートのO列2行目以下に数式挿入:=IF(mod(row()-1,10)=1,IF(N2="","",N2),O1) .Range("O2:O4994").FormulaR1C1 = "=IF(MOD(ROW()-1,10)=1,IF(RC[-1]="""","""",RC[-1]),R[-1]C)" '作業用シートのO列をコピーし、そのまま値貼り付け .Columns("O").Value = .Columns("O").Value '作業用シートのN列を削除 .Columns("N").Delete '作業用シートのA、B列の空白セルをジャンプ機能で選択 .Columns("A:B").Select Selection.SpecialCells(xlCellTypeBlanks).Select '上記範囲に、数式挿入:=A2 Selection.Formula = "=A2" '作業用シートA、B列をコピーし、そのまま値貼り付け .Columns("A:B").Value = .Columns("A:B").Value '作業用シートのオートフィルタ—で1)の日付より前、且つ1)の日付より後を抽出 .Rows(1).Select Columns("A:N").AutoFilter Field:=8, Criteria1:="<>" & 日付, Operator:=xlFilterValues Columns("A:N").SpecialCells(xlCellTypeVisible).Delete If Not WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 Then '作業用シートのC、D列に数式入力:=Vlookup(A1,sheet2!$a:$g,4,0) .Range("C1", Cells(Rows.Count, 3).End(xlUp)).Formula = "=Vlookup(A1,sheet2!$A:$G,4,0)" .Range("D1", Cells(Rows.Count, 4).End(xlUp)).Formula = "=Vlookup(A1,sheet2!$A:$G,6,0)" '作業用シートのE列に数式入力:=Vlookup(A1,sheet2!$a:$g,7,0) .Range("E1", Cells(Rows.Count, 5).End(xlUp)).Formula = "=Vlookup(A1,sheet2!$A:$G,7,0)" '作業用シートのデータをコピーし、抽出マクロブックのsheet1の最下行の下に値貼り付け Range("A1").CurrentRegion.Copy 抽出WS.Range("A4").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If End With '管理用ブックを保存しないで閉じる ActiveWorkbook.Close False '以上をすべての「管理表_*.xlsm」で、繰り返す myFile = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic End Sub （125） 2018/11/27(火) 16:55 ---- ＞次はその改善をしたいと思います。結合セルやチェックボックスの利用をやめてフィルターが使いやすいフォーマットに変更すると良いと思います。（マナ） 2018/11/27(火) 18:41 ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/201811/20181109152329.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ