[[20150331213635]] 『表から1周間分の名前を抜き出すマクロ』(ユウコ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『表から1周間分の名前を抜き出すマクロ』(ユウコ)

お世話になります。

 シート名は月(m月)、中に日付入りの表が縦に並んでおり
 B列に日付があり、表は日付を入れて30行です
 その表が1年分あったとして(日付はランダムです)
 同じ形式のブックが複数あります(仮にAA,BB,CC,DD,EEとして)
 印刷用ブック「一覧」シートからマクロを動かしたら
 明日から7日間の日付を検索し、該当表のA:C行を
 一覧シートのA1からC30までコピーし、次の表は
 D1からF30へ…というように横にコピーたいのです。
 意味は理解してもらえるでしょうか?
 贅沢な注文で申し訳ありませんが、このようなことは
 可能でしょうか?
 皆様、お力添えをよろしくお願いします。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 いくつか確認したいのですが、
 ・どのファイルのどのシートからコピーしたという情報はなくともよいのですか。
 ・7日間の日付を検索とは、例えば3/28 日に実行したら、3月と4月のシートが対象になるのですか。
 ・日付には年の情報があるのでしょうか(12月に実行したら、1月は今年?来年?)。

(Mook) 2015/03/31(火) 22:21


MooKさま
 ありがとうございます。
 確かにそうでした…
 ・可能であれば1行目(空行)にブック名が入るとありがたいです
 ・月末の検索の場合はシートがまたぐことになります
 ・日付は書式をmm/dd/(aaa)で表示していあります
 お手数をお掛けします。よろしくお願いします。
(ユウコ) 2015/04/01(水) 06:45

 とりあえずのサンプルです。
 1行目にファイル名、2行目にシート名、4行目以降にデータをコピーしています。
 検索対象は、マクロのあるブックと同じフォルダにあるファイルです。

 Sub Sample()
    '// ツール ⇒ 参照設定 Microsoft Scripting Runtime にチェック
    Dim fso As New Scripting.FileSystemObject

    Dim dstWS As Worksheet
    Set dstWS = ThisWorkbook.Worksheets("一覧")
    dstWS.Cells.Clear

    Dim f
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        If f.Name <> ThisWorkbook.Name Then
            If InStr(UCase(fso.GetExtensionName(f.Name)), "XLS") > 0 Then
                dataCopy f.Path, dstWS, Date + 1, Date + 7
            End If
        End If
    Next
 End Sub

 Sub dataCopy(dataPath As String, dstWS As Worksheet, sd As Date, ed As Date)
    Dim ws As Worksheet
    Dim t
    Dim r As Long
    Dim c As Long

    With Workbooks.Open(dataPath)
        For Each ws In .Worksheets
            t = ws.Range("A1:C30")
            For r = 1 To 30
                If t(r, 2) <> "" Then
                    If t(r, 2) >= sd And t(r, 2) <= ed Then
                        c = dstWS.Cells(1, Columns.Count).End(xlToLeft).Column
                        If dstWS.Cells(1, c).Value <> "" Then c = c + 3
                        dstWS.Cells(1, c).Value = .Name
                        dstWS.Cells(2, c).Value = ws.Name
                        ws.Range("A1:C30").Copy dstWS.Cells(4, c).Resize(30, 3)
                        dstWS.Cells(4, c).Resize(30, 3).Value = dstWS.Cells(4, c).Resize(30, 3).Value
                        Exit For
                    End If
                End If
            Next
        Next
        .Close False
    End With
 End Sub

(Mook) 2015/04/01(水) 10:48


 AA,BBといったブックのシートの1行目がタイトル行であれば、フィルタリング機能が使えます。
 効率的にはフィルターオプション(フィルター詳細設定)が優れていますが、各ブックのタイトル文字列の
 不一致によっては障害になるケースがありますので、オートフィルター機能を使いました。
 月またがりの場合は同じ列の下に転記します。

 ブックが保存されているフォルダ、以下の例では DeskTop上の "test" という名前にしてあります。

 追記です。(11:36)

 当日日付を基本に処理すると、後日に処理したい場合に、困ってしまうことが往々にしてあります。
 なので、以下の例では、デフォルトとして、翌日の日付を表示して、それでよければOKをクリック、
 後追い処理等の場合は、抽出開始日を打ち直してOKをクリック。
 日付は 2015/3/26 といった形でもいいですし、2015年3月26日 といった形でもいいです。

 またまた追記です。 (11:47)

 マクロブックが同じフォルダにあった場合のスキップを追加しました。

 Sub Test()
    Dim fDate As Date
    Dim tDate As Date
    Dim fPath As String
    Dim fName As String
    Dim fromNM As String
    Dim toNM As String
    Dim fromSh As Worksheet
    Dim toSh As Worksheet
    Dim fromBk As Workbook
    Dim selNMs As Variant
    Dim shn As Variant
    Dim setColTop As Range
    Dim setpos As Range
    Dim done As Boolean

    Application.ScreenUpdating = False

    '初期値を翌日として開始日付を指定
    fDate = Date + 1
    fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1)
    If fDate = 0 Then Exit Sub  'キャンセルボタン

    tDate = fDate + 6   '終了日付

    fromNM = Month(fDate) & "月"    '抽出対象開始シート名
    toNM = Month(tDate) & "月"      '抽出対象終了シート名
    If fromNM = toNM Then
        selNMs = Array(fromNM)
    Else
        selNMs = Array(fromNM, toNM)
    End If

    Set toSh = ThisWorkbook.Sheets("一覧")
    toSh.UsedRange.ClearContents        '処理前に一覧シートをクリア
    Set setColTop = toSh.Range("A1")       '転記開始セル

    '★抽出対象ブックのフォルダパス。実際のものに変更
    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\TEST\"

    fName = Dir(fPath & "*.xls")    'フォルダからブックを抽出

    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set fromBk = Workbooks.Open(fPath & fName)  '対象ブックを開く
                done = False
            For Each shn In selNMs
                Set fromSh = Nothing
                On Error Resume Next
                Set fromSh = fromBk.Sheets(shn)         '対象シート
                On Error GoTo 0
                If fromSh Is Nothing Then
                    MsgBox fromBk.Name & " に " & shn & "がないのでスキップします"
                Else

                    fromSh.AutoFilterMode = False   'オートフィルター解除

                    fromSh.Range("A1").AutoFilter 2, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate)
                    '抽出があれば
                    If Not done Then setColTop.Value = fName
                    If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                        Set setpos = setColTop.Offset(1)
                        If done Then Set setpos = setColTop.End(xlDown).Offset(1)
                        '転記
                        If done Then
                            Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Copy setpos
                        Else
                            fromSh.AutoFilter.Range.Copy setpos
                        End If
                        done = True
                    End If

                End If

            Next

            fromBk.Close False          '対象ブックを閉じる
            fName = Dir()               '次のブック
            Set setColTop = setColTop.Offset(, 3) '次の転記位置
        End If
    Loop

 End Sub

(β) 2015/04/01(水) 11:35


Mookさん、βさんありがとうございます。
 いま、試行できる環境にないので
 試行して、またお助け頂くと思います。
 少々お待ちください。
(ユウコ) 2015/04/01(水) 16:01

Mookさん遅くなりました。
 With Workbooks.Open(dataPath)のところでエラーがでます。
 「エクセルで$印刷用.xlsmを開くことができません…」という内容です
 印刷用ブックは対象ブックと同じフォルダに入っており
 それを開いてマクロを動かしております。
 わたしが大きな勘違いをしているのでしょうか。
 申し訳ありません。尚、フォルダには検索対象以外のブックも
 いくつか含まれています。
 お手数をお掛けします。

 βさん、1行目は空白、2行目に日付のみ、3行目が見出、4行目以降がデータです
 その表が30行ごとに縦にずらっと並んでいます、
 時間がなくて、これから教えて頂いたものを施行してみます
 遅くなってすいません。
(ユウコ) 2015/04/01(水) 21:19

 >βさん、1行目は空白、2行目に日付のみ、3行目が見出、4行目以降がデータです
 >その表が30行ごとに縦にずらっと並んでいます、

 であれば、コードが意識しているレイアウトとは異なりますので、実行しても無意味ですよ。

(β) 2015/04/01(水) 21:28


 通常のファイルに $ が付くことがなければ、

        If f.Name <> ThisWorkbook.Name Then
 を
        If f.Name <> ThisWorkbook.Name And InStr( f.Name, "$" ) = 0 Then
 としてみてください。

 データは、縦に複数セットありますか。
 30行だけだと思い込んでいましたが。

(Mook) 2015/04/01(水) 21:50


 レイアウトをそちらのものに合わせ、マクロブックフォルダと対象ブックフォルダを同じ場所にしたコードです。

 Sub Test2()
    Dim fDate As Date
    Dim tDate As Date
    Dim fPath As String
    Dim fName As String
    Dim fromNM As String
    Dim toNM As String
    Dim fromSh As Worksheet
    Dim toSh As Worksheet
    Dim fromBk As Workbook
    Dim selNMs As Variant
    Dim shn As Variant
    Dim setColTop As Range
    Dim setpos As Range
    Dim done As Boolean
    Dim afR As Range

    Application.ScreenUpdating = False

    '初期値を翌日として開始日付を指定
    fDate = Date + 1
    fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1)
    If fDate = 0 Then Exit Sub  'キャンセルボタン

    tDate = fDate + 6   '終了日付

    fromNM = Month(fDate) & "月"    '抽出対象開始シート名
    toNM = Month(tDate) & "月"      '抽出対象終了シート名
    If fromNM = toNM Then
        selNMs = Array(fromNM)
    Else
        selNMs = Array(fromNM, toNM)
    End If

    Set toSh = ThisWorkbook.Sheets("一覧")
    toSh.UsedRange.ClearContents        '処理前に一覧シートをクリア
    Set setColTop = toSh.Range("A1")       '転記開始セル

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xls")    'フォルダからブックを抽出

    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set fromBk = Workbooks.Open(fPath & fName)  '対象ブックを開く
                done = False
            For Each shn In selNMs
                Set fromSh = Nothing
                On Error Resume Next
                Set fromSh = fromBk.Sheets(shn)         '対象シート
                On Error GoTo 0
                If fromSh Is Nothing Then
                    MsgBox fromBk.Name & " に " & shn & "がないのでスキップします"
                Else

                    fromSh.AutoFilterMode = False   'オートフィルター解除
                    Set afR = fromSh.Range("A3", fromSh.Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
                    afR.AutoFilter 2, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate)
                    '抽出があれば
                    If Not done Then setColTop.Value = fName
                    If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                        Set setpos = setColTop.Offset(1)
                        If done Then Set setpos = setColTop.End(xlDown).Offset(1)
                        '転記
                        If done Then
                            Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Copy setpos
                        Else
                            fromSh.AutoFilter.Range.Copy setpos
                        End If
                        done = True
                    End If

                End If

            Next

            fromBk.Close False          '対象ブックを閉じる
            Set setColTop = setColTop.Offset(, 3) '次の転記位置
        End If

        fName = Dir()               '次のブック

    Loop

 End Sub

(β) 2015/04/01(水) 22:09


Mookさん、βさんありがとうございます
 私の説明が大変・大変下手くそでご迷惑をお掛けしているようで
 大変心苦しいです。
 更に説明不足の部分も発覚し、もう一度説明させてもらいます
 (お二人にマクロはしっかり動きました)
 一番説明不足だったのは検索対象ブックに年度のカレンダーが1シート
 含まれていた点です。日付だけで検索して頂いていたため、それが検索で
 あたってしまって印刷用に抽出されています検索対象から各ブックの左端にある
 「カレンダー」シートを省くことは可能でしょうか?
 もし無理でしたら、手作業で削除できます。
 あともう一つ…(本当にすいません)
 私の表の提示が間違っていました。
 1行目空白行と書きましたが、各シート(m月)の最初の1行目だけが空白行で、
 2行目からは、空白行がありませんでした。しかも毎回空白行があると思って
 いたので、表の行数も間違っていました。
 各シートの1番最初の行だけ空白で、2行目から表が始まります
 表の最初のB列に日付(mm月dd日(aaa)があり、1つの表は
 日付を入れて29行です。
 指定日(明日から7日)以内の日付があった場合
 1行目にブック名を入れ
 その下に日付のある表のA1行目からC29行目までのデータを
 印刷用ブック「一覧」シートに貼り、それ以降の対象日データは
 印刷用ブックに横に張付けていきたいのです。
 全く周りっくどい表現しかできず、ほんとうにごめんなさい。
 Mookさんのマクロは、多分私の行の説明間違いで
 対象日の検索がずれてしまっていたようです。
 βさんのは、「日付があれば表を含むA〜C29行を」の部分が
 上手く伝わっていなかったようで、対象の日付だけが抽出さました。
 お二人、本当にお手数をお掛けします。
 よろしくお願いします。

(ユウコ) 2015/04/02(木) 06:08


 この手のものは、いくら言葉で説明しても、やはり受け取り側に誤解が生じる可能性があります。

 レイアウトサンプルを目で見てわかる形で、アップされてはいかがでしょう。
 「学校」内に、たくさん事例がありますが、

[[20150330153541]] 『受注データから在庫一覧をもとに、上から順に在庫』(NAO) 

 とか、

[[20150206135317]] 『リストの不連続印刷について』(sarara)

 にあるような形で。

(β) 2015/04/02(木) 06:17


 まず、m月シートのレイアウト、1行目から30行目までは以下でいいですか?
 それとも、どこか違っていますか?

 次に、31行目から59行目までは、こんな感じでいいですか?それとも違っていますか?

 それと、以下の日付が範囲内だった場合、この m月シートの、どこからどこまでを、一覧シートの、どこに、どのように転記をしますか?
   
   [A]    [B]    [C]
[1] 空白行		
[2] ああああ 2015/4/1 いいいい
[3] 項目A1  項目B1  項目C1
[4] 項目A2  項目B2  項目C2
[5] 項目A3  項目B3  項目C3
[6] 項目A4  項目B4  項目C4
[7] 項目A5  項目B5  項目C5
    			
途中 省略		
    	
[28] 項目A26 項目B26 項目C26
[29] 項目A27 項目B27 項目C27
[30] 項目A28 項目B28 項目C28
[31] うううう 2015/4/2 ええええ
[32] 項目A30 項目B30 項目C30
[33] 項目A31 項目B31 項目C31
[34] 項目A32 項目B32 項目C32
[35] 項目A33 項目B33 項目C33
[36] 項目A34 項目B34 項目C34
[37] 項目A35 項目B35 項目C35
     
途中 省略		
     			
[58] 項目A56 項目B56 項目C56
[59] 項目A57 項目B57 項目C57

(β) 2015/04/02(木) 08:58


 βさんの想定データで変更しました。

 Sub Sample()
    '// ツール ⇒ 参照設定 Microsoft Scripting Runtime にチェック
    Dim fso As New Scripting.FileSystemObject

    Dim dstWS As Worksheet
    Set dstWS = ThisWorkbook.Worksheets("一覧")
    dstWS.Cells.Clear

    Dim f
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        If f.Name <> ThisWorkbook.Name And InStr(f.Name, "$") = 0 Then
            If InStr(UCase(fso.GetExtensionName(f.Name)), "XLS") > 0 Then
                dataCopy f.Path, dstWS, Date + 1, Date + 7
            End If
        End If
    Next
 End Sub

 Sub dataCopy(dataPath As String, dstWS As Worksheet, sd As Date, ed As Date)
    Dim t
    Dim r As Long
    Dim c As Long

    Dim ws As Worksheet

    Dim wa
    If Month(sd) = Month(ed) Then
        wa = Array(Month(sd) & "月")
    Else
        wa = Array(Month(sd) & "月", Month(ed) & "月")
    End If

    Dim wi As Long
    With Workbooks.Open(dataPath)
        For wi = 0 To UBound(wa)
            On Error Resume Next
            Set ws = .Worksheets(wa(wi))
            On Error GoTo 0
            If Not ws Is Nothing Then
                For r = 1 To ws.Cells(Rows.Count, "B").End(xlUp).Row
                    If IsDate(ws.Cells(r, "B").Value) = True Then
                        If ws.Cells(r, "B").Value >= sd And ws.Cells(r, "B").Value <= ed Then
                            c = dstWS.Cells(1, Columns.Count).End(xlToLeft).Column
                            If dstWS.Cells(1, c).Value <> "" Then c = c + 3
                            dstWS.Cells(1, c).Value = .Name
                            dstWS.Cells(2, c).Value = ws.Name
                            ws.Cells(r, "A").Resize(29, 3).Copy dstWS.Cells(4, c).Resize(29, 3)
                            dstWS.Cells(4, c).Resize(29, 3).Value = dstWS.Cells(4, c).Resize(29, 3).Value
                        End If
                    End If
                Next
            End If
        Next
        .Close False
    End With
 End Sub

(Mook) 2015/04/02(木) 14:10


 本題とずれますが、横からお邪魔します。
 投稿用にレイアウトしてくれる便利なコードを
 以前momoさんが作成してくれていますのでご紹介〜
[[20110209184943]]
 『[談]シートレイアウトの投稿どうしてますか?』(momo)
(とおりすがりん♪) 2015/04/02(木) 18:16

 わぁ! これは便利ですねぇ。
 早速使わせてもらいます。
 以下は、どうなるんだろうということで、ちょこちょこっとシート上で作成したものです。

    |[A]    |[B]  |[C]        |[D]        
 [1]|項目1  |項目2|項目3      |項目4      
 [2]|あああ1|  100|         10|         20
 [3]|あああ2|  200|         30|         40
 [4]|あああ3|  300|=SUM(C2:C3)|=SUM(D2:D3)
 [5]|あああ4|  400|        100|        200
 [6]|あああ5|  500|        300|        400
 [7]|あああ6|  600|=SUM(C5:C6)|=SUM(D5:D6)

(β) 2015/04/02(木) 19:14


みなさん 色々ありがとうございます。
 お返事が遅くなりすいません。
 年度はじめで非常に非常に忙しくて…
 表を実際書けばよかったのですね。
 頭が回らずすいません。
 先に結論をお話してしまいますが、Mookさんのマクロで
 希望通りに動いたようです(まだ詳細が確認できていないですが)
 表ですがAA〜EEのブックは最初がカレンダーシートで
 それ以降 mm月シートで以下の配列です

  [A]    [B]    [C]・・・
 [1] 空白行		
 [2]      日付 
 [3] 項目A1  項目B1  項目C1
 [4] 項目A2  項目B2  項目C2
 [5] 項目A3  項目B3  項目C3
   			
  途中 省略		
    	
 [29] 項目A27 項目B27 項目C27
 [30] 項目A28 項目B28 項目C28
 [31] 項目A29 項目B29 項目C29
 [32]            日付
 [33] 項目A31 項目B31 項目C31
 [34] 項目A32 項目B32 項目C32
          以下500行程度まで

 印刷用ブックの一覧シートは白紙で
 そこのマクロを発動させたら、各ブックから7日以内の日付を検索し
 日付があれば日付と以下のA〜C列の日付を含めて29行をコピーし
 一覧シートのA列〜C列、D列〜F列へと横に貼り付けていきたい 
 というものでした。
 詳細を確認し、またお返事いたします。

(ユウコ) 2015/04/02(木) 21:51


 それでは、私がアップしたオートフィルター版を無理やり(?)継承したものを。
 ただし、Mookさんの結果は、月ごとに転記列をわけておられますが、私のコードは、1つのブックからは
 月またがりの場合も同じ列に転記します。

 Sub Test3()
    Dim fDate As Date
    Dim tDate As Date
    Dim fPath As String
    Dim fName As String
    Dim fromNM As String
    Dim toNM As String
    Dim fromSh As Worksheet
    Dim toSh As Worksheet
    Dim fromBk As Workbook
    Dim selNMs As Variant
    Dim shn As Variant
    Dim setColTop As Range
    Dim setpos As Range
    Dim done As Boolean
    Dim afR As Range

    Application.ScreenUpdating = False

    '初期値を翌日として開始日付を指定
    fDate = Date + 1
    fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1)
    If fDate = 0 Then Exit Sub  'キャンセルボタン

    tDate = fDate + 6   '終了日付

    fromNM = Month(fDate) & "月"    '抽出対象開始シート名
    toNM = Month(tDate) & "月"      '抽出対象終了シート名
    If fromNM = toNM Then
        selNMs = Array(fromNM)
    Else
        selNMs = Array(fromNM, toNM)
    End If

    Set toSh = ThisWorkbook.Sheets("一覧")
    toSh.UsedRange.ClearContents        '処理前に一覧シートをクリア
    Set setColTop = toSh.Range("A1")       '転記開始セル

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xls")    'フォルダからブックを抽出

    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set fromBk = Workbooks.Open(fPath & fName)  '対象ブックを開く
                done = False
            For Each shn In selNMs
                Set fromSh = Nothing
                On Error Resume Next
                Set fromSh = fromBk.Sheets(shn)         '対象シート
                On Error GoTo 0
                If fromSh Is Nothing Then
                    MsgBox fromBk.Name & " に " & shn & "がないのでスキップします"
                Else

                    fromSh.AutoFilterMode = False   'オートフィルター解除
                    fromSh.Range("A1:D1").Value = "A"   'Dummy Title
                    Set afR = fromSh.Range("A1").CurrentRegion.Columns("A:D")
                    afR.Offset(1, 3).Resize(afR.Rows.Count - 1, 1).Formula = "=OFFSET(B2,-MOD((ROW()-2+29),29),0)"
                    afR.AutoFilter 4, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate)
                    '抽出があれば
                    If Not done Then setColTop.Value = fName
                    If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                        Set setpos = setColTop.Offset(1)
                        If done Then Set setpos = setColTop.End(xlDown).Offset(1)
                        '転記
                        Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Columns("A:C").Copy setpos
                        done = True
                    End If

                End If

            Next

            fromBk.Close False          '対象ブックを閉じる
            Set setColTop = setColTop.Offset(, 3) '次の転記位置
        End If

        fName = Dir()               '次のブック

    Loop

 End Sub

(β) 2015/04/02(木) 22:10


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.