[[20181109152329]]　『複数ブック複数シートのデータ抽出』（１２５）　ページの最後に飛ぶ

『複数ブック複数シートのデータ抽出』（１２５）

お世話になっております。
テレフォンアポイントの結果（当日分）を抜き出すマクロを考えております。

電話をかけ終わった後、下記のように誰にかけて何を話したのか記録を残すようにしています。
sheet1には少しわかりずらいと思うのですが1つの会社ごとに１０列設けており（例では5行にしています…）、A～D列までは10行ごとに列で結合させています。
E列より1回の電話を掛けるごとに1行ずつ記入するようなしくみにしております。
sheet2はデータベースのようなフォーマットで、電話した会社の情報を表示させています。

（管理表ブック＿sheet１）

    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   良　 ●   -    -   -

（管理表ブック＿sheet２）

    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列）が検索され、各ブックの各シートのから情報が抽出されるようにしたいです。
抽出項目が各シートにまたがっており、なかなかうまく実行できません。

（抽出マクロブック＿sheet１）

    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

こんな感じでどうでしょうか。
結構、先は長そうですが、１つずつ考えていくと良いです。

 　
１）管理表ブックのsheet2で1/2 データをオートフィルタ（フィルタオプション）で作業用シートに転記
２）転記された会社を１個ずつ、sheet1のB列から検索
３）検索された行のG列から下に10セルの範囲から、１/2を検索
４）検索された行のデータを作業用シートに転記
５）これを１）で転記された、すべての会社で繰り返す。
６）作業用シートから、抽出マクロブックのsheet1に転記
７）以上を、９個の管理用ブックで繰り返す

（マナ） 2018/11/09(金) 19:21

マナさん

コメントありがとうございます。
言葉足らずの説明で申し訳ないのですが、
sheet1のH列で日付を検索してデータを抽出したいのです。
sheet1で検索した企業をsheet2で検索するといったマクロにしたいのですが、
希望通りの情報を抽出できるマクロになりませんでした。

また、同フォーマットのブックは全部で8つ
E列に1行追加されたフォーマット（E列の情報は抽出する必要なし）が1つです。

以上、宜しくお願い致します。
（１２５） 2018/11/10(土) 08:58

＞sheet1のH列で日付を検索してデータを抽出したいのです。

１）G列の間違いでしょうか？
２）sheet2のH列で検索してはなぜだめなのでしょうか？

（マナ） 2018/11/10(土) 09:09

マナさん

すみません、G列の間違いです。

sheet2は電話を掛けた日ではなく、最初に電話をかけるために会社の情報を登録した日となっています。
ユーザフォームで会社の住所・電話番号などを登録するようにしており、その情報がsheet2とsheet1のB列、D列に飛ぶようになっております。
（１２５） 2018/11/10(土) 09:30

理解しました。

では、sheet1データの右側O列以降は空いていますか。
作業列として使用可能ですか。

（マナ） 2018/11/10(土) 09:42

マナさん

抽出マクロブックのsheet1でしょうか？
そちらのシートでしたらO列以降は何もデータが入っておりません。
（１２５） 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のみにフィルターをかけています。

後出し後出しで申し訳ございませんが、宜しくお願い致します。
（１２５） 2018/11/10(土) 10:45

返事いただいていたのに気づいていませんでした。

＞抽出マクロブックのsheet1でしょうか？

違います。管理用ブックのsheet1です。

見出しについては理解しました。

（マナ） 2018/11/10(土) 10:50

ごめんなさい。
O列以降ではなく、Q列以降の間違いでした。

（マナ） 2018/11/10(土) 10:52

マナさん

P列以降もQ・Rは入力規制のためのデータや数式が入っております。
S列以降でしたら、何もデータがない状態です。
（１２５） 2018/11/10(土) 11:05

たぶん、こんな感じでできると思いますので、考えてみてください。
まずは、１つの管理用ブックについて、手作業で試してみてはどうでしょうか。
マクロもいきなり完成形を目指す必要はありません。
１つずつ考えていくとよいです。

１）管理表ブックのsheet1のQ列に７列挿入
２）管理表ブックのsheet1の４行目をコピーし、５行目に挿入
３）heet1ののM3:P3を、M5:P5にコピー
４）sheet2のA1:G1をコピーし、Sheet1のQ5に貼り付け
５）Sheet1のO列6行目以下に数式挿入：=IF(a6="",Q5,a6)
６）Sheet1のp列以降も数式挿入：=Vlookup(Q6,sheet2!$a:$g,2,0)
７）Sheet1の1/2 データをフィルタオプションで作業用シートに転記
８）作業用シートから、抽出マクロブックのsheet1に転記
９）sheet1のQ～W列を削除
10）sheet1の5行目を削除
11）以上を、９個の管理用ブックで繰り返す

（マナ） 2018/11/10(土) 11:17

↑５行目に用意したフィルターオプション用の見出しで、
K列は、別の別の見出しに修正する作業が必要でした。

（マナ） 2018/11/10(土) 11:23

マナさん

上記の方法を試してみました。
１つ伝え漏れていたことがありまして、管理ブックのsheet1のP列なのですが、
A列～D列同様に10行ごとに結合してあります。

5）・6）の内容ですが、O・P列ともに抽出したい情報なので
関数を入れてしまうと情報が全て関数結果になってしまいます。

私が試した方法でsheet1のE～H列の4行目にオートフィルタを入れ
日付を抽出するやり方でしたら、該当日付のデータが1行ずつ検索され、
思い通りの内容になったのでその状態から、欲しい項目だけを抜き出す
というのが課題なのかなと自分なりに思っております。

恐らくマナさんのやり方は見出しを設定しなおすことと、1シートに情報をまとめて
一気に情報を吸い取るやり方なのではないかと推測しております（違っていたらすみません）。
そうできれば一番良いのですが、sheet1とsheet2の行単位の塊が違うため（sheet1は10行で1企業
sheet2は1行1企業）、なかなかそこをマッチさせることが難しいです・・・。

（１２５） 2018/11/10(土) 11:52

このような感じです。

（管理表ブック＿sheet１）

    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   良　 ●   -

（１２５） 2018/11/10(土) 11:55

＞５）Sheet1のO列6行目以下に数式挿入：=IF(a6="",Q5,a6)
＞６）Sheet1のp列以降も数式挿入：=Vlookup(Q6,sheet2!$a:$g,2,0)

間違えました

５）Sheet1のQ列6行目以下に数式挿入：=IF(a6="",Q5,a6)
６）Sheet1のR列以降も数式挿入：=Vlookup(Q6,sheet2!$a:$g,2,0)

です。

（マナ） 2018/11/10(土) 12:02

P列も結合セルなら

A列と同じように、↓数式で対応するとよいです。

＞５）Sheet1のQ列6行目以下に数式挿入：=IF(a6="",Q5,a6)

（マナ） 2018/11/10(土) 12:14

マナさん

ご連絡が遅くなってしまい、申し訳ございません。
マナさんの方法で一先ず1ブックのみマクロを記録させてみました。
この方法で正常にコピペはできたのですが、処理速度が遅くいのです(泣)
管理ブックのsheet1は5000行ほどあり、チェックボックスが1000個程入っているため
ブックを開くこと自体重いのですが、7列挿入するところにかなりの時間を要してしまい、
これを残り8ブックするとなると、少し時間がかかりすぎてしまうのかなと思っております。

挿入以外で何か方法がありましたらご教授いただきたいです。
（１２５） 2018/11/12(月) 10:55

＞7列挿入するところにかなりの時間を要してしまい

では。手作業で、↓ここの時間はどうですか？

＞４）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)作業用シートのＯ列をコピーし、そのまま値貼り付け
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行単位での構成のためオートフィルをすると情報が出てくる行と、エラーになってしまう行があります。

お手数おかけしますが、宜しくお願い致します。

（１２５） 2018/11/13(火) 11:33

手順を修正です

 ＞8)業用シートの2行目を行削除
 　　　↓
 　8)作業用シートの４行目を削除後、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

（１２５） 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とでてしまいました。。。
（１２５） 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

ねむねむさん
数式のご指摘ありがとうございます。
無事、反映されました。
数式はカンマに直したのですが、こちらに貼った数式はピリオドのままでした。
誤解を招いてしまい、申し訳ございませんでした。
（１２５） 2018/11/15(木) 14:49

手作業では、期待する結果になりましたか。
それとも、まだ異なる点がありますか。

もし期待通りであれば、以下について教えてください。

＞そのうちの1ブックはほかのブックよりも1列多いフォーマットになっているため

これが理解できていません。
１列多い管理表ブックでは、上記手順のどこを変更する必要がありますか。

（マナ） 2018/11/15(木) 19:54

マナさん

お世話になっております。
おかげさまで求めている形になりました。

違うフォーマットの件ですが、下記のようなフォーマットになっております。
（管理表ブック＿sheet１）

    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の情報を拾う必要はありません。

以上、宜しくお願い致します。
（１２５） 2018/11/16(金) 10:26

E列が挿入されただけで順番は同じ表ということですね。

１）９つの管理表ブックは１つの同じフォルダに保存されているのでしょうか
２）１列多い管理表ブックも同じフォルダでしょうか
３）抽出マクロブックも同じフォルダでしょうか
４）どれが１列多いブックか、ブックを開かないとわからのでしょうか

（マナ） 2018/11/17(土) 08:21

マナさん

お世話になっております。
１）、２）、３）すべて同じフォルダに格納されております
４）ブックの名前が全て違いますので、区別はできます。

以上、宜しくお願い致します。
（１２５） 2018/11/19(月) 10:15

＞４）ブックの名前が全て違いますので、区別はできます。

具体的に、説明していただけますか。
名前のルールが決まっていると、
マクロで判断させることができます。

（マナ） 2018/11/19(月) 18:31

マナさん

ブックは都道府県別になっています。
ブック名は『管理表_●●県.xlsm』のルールで作成されております。
ちなみに1列多い行のブックは『管理表_茨城県.xlsm』です。

以上、宜しくお願い致します。
（１２５） 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

お手数おかけしますが、宜しくお願い致します。
（１２５） 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)とエラーが出ます。

また、作業用シートが抽出マクロブックの先頭に作成されるのですが、
私の認識だと管理用ブックの最後尾にシートが作成されると思っていたのですが、ただの認識間違いでしょうか？

至らない質問ばかりで申し訳ございませんが、何卒宜しくお願い致します。

（１２５） 2018/11/22(木) 11:44

始めからステップインしなおしたのですが、
withのエラーが出ませんでした（上記は私のやり方が悪かったようです…）。

しかし、抽出した結果が求めたい抽出マクロブックのsheet1のA1の値ではなかったことと
オートフィルの後、行を削除するとAB列の値が全て残っており、そのほかの列のもまばらに値が残っています。

何か改善策はありますでしょうか？
度々申し訳ございませんが、宜しくお願い致します。
（１２５） 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)作業用シートのオートフィルタ―で、１）の日付より前　または１）の日付より後 を抽出
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

以上、お忙しいところ恐れ入りますが宜しくお願い致します。
（１２５） 2018/11/26(月) 17:16

＞'「管理表_茨城県.xlsm」以外ならば、A～R列をコピー
＞Sheets("sheet1").Columns("A:R").Copy

A～Pの間違いでした。
申し訳ございません。
（１２５） 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

（１２５） 2018/11/27(火) 16:55

＞次はその改善をしたいと思います。

結合セルやチェックボックスの利用をやめて
フィルターが使いやすいフォーマットに変更すると良いと思います。

（マナ） 2018/11/27(火) 18:41

コメント返信：

[ 一覧(最新更新順) ]

[[20181109152329]] 『複数ブック複数シートのデータ抽出』（１２５） ページの最後に飛ぶ

*ここから下***の部分がエラーが出て実行できませんでした。（改善のマクロもわかりませんでした）

[[20181109152329]]　『複数ブック複数シートのデータ抽出』（１２５）　ページの最後に飛ぶ