[[20150130163003]] 『複数のブックを開き、該当シートを1つのブックに』(櫻井) ページの最後に飛ぶ

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

 

『複数のブックを開き、該当シートを1つのブックにまとめたい』(櫻井)

閲覧頂きありがとうございます。

・毎月同一フォーマットを使い、集計しているデータを使用
・ブック名はそれぞれH●年●月以下同文
・シート名は東京・神奈川など各エリアですべて同一(10シート)
・1〜6行は不要の為、7行目からコピーをしてまとめたい
・空白行も混入しており、H列が空白の場合は全て削除して取り除きたい
・使用したブックは保存せず終了させたい
・1つにするブックはフォーマット作成済でそこにコピー、シート名は上記と同じく各エリア

それを3ヶ月ごとに1つのデータにまとめて提出することとなりました。
初めての質問でどのようにお伝えすれば良いかわかりませんが、ご教示くださると幸いです。

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


 そのフォーマットの説明がないと、どうにもできないのでは?
 ブックは同じフォルダ?
 コピーしてどこに、どのようにまとめるの?
 H列が空白の場合、行のすべて?それともシートすべて削除?
(稲葉) 2015/01/30(金) 17:15

 とりあえず。

 デスクトップ上に 「月別データ」というフォルダをつくり、そこに集約したい月別ブックのみを格納。
 それらを新規ブックにまとめるところまで。
 タイトルを残したいとか、できれば集約したものを保存したいとか、リスエストは後に回して
 まずは、おおよその仕様の勘違いがあるか、これでいいのか、確認お願い。

 Sub 集約()
    Dim sh As Worksheet
    Dim bk As Workbook
    Dim mPath As String
    Dim fName As String
    Dim r As Range
    Dim newBk As Workbook
    Dim newSh As Worksheet
    Application.ScreenUpdating = False

    mPath = CreateObject("WScript.shell").specialfolders("desktop") & "\" & "月別データ" & "\"

    fName = Dir(mPath & "*.xls")

    Do While Len(fName) > 0

        Set bk = Workbooks.Open(mPath & fName)

        For Each sh In bk.Worksheets
            With sh.Range("A1", sh.UsedRange)
                Set r = .Offset(6).Resize(.Rows.Count - 6)
            End With

            If WorksheetFunction.CountBlank(r.Columns("H")) <> r.Rows.Count Then
                If newBk Is Nothing Then
                    sh.Copy
                    Set newBk = ActiveWorkbook
                    newBk.Sheets(1).Rows("1:6").ClearContents
                Else
                    Set newSh = Nothing
                    On Error Resume Next
                    Set newSh = newBk.Sheets(sh.Name)
                    On Error GoTo 0
                    If newSh Is Nothing Then
                        sh.Copy after:=newBk.Worksheets(newBk.Worksheets.Count)
                        Set newSh = ActiveSheet
                        newSh.Rows("1:6").ClearContents
                    Else
                        r.Copy newSh.Range("A" & newSh.UsedRange.Row + newSh.UsedRange.Rows.Count)
                    End If
                End If
            End If
        Next

        bk.Close False
        fName = Dir()

    Loop

 End Sub

(β) 2015/01/30(金) 17:30


データ中に年月日情報もあるのだろう、という前提で、コピーだけ行う例。

 Sub test()
    Const cPATH = "c:\test\"
    Dim wk As Worksheet
    Dim cFile As String
    Dim i As Long
    Dim j As Long
    Dim iR As Long
    Dim iMax As Long

    Application.ScreenUpdating = False
    Application.ShowWindowsInTaskbar = False
    Application.EnableEvents = False

    cFile = Dir(cPATH & "H*.xls*")
    While cFile <> ""
        With Workbooks.Open(cPATH & cFile, False, True)
            For i = 1 To .Sheets.Count
                Set wk = ThisWorkbook.Sheets(.Sheets(i).Name)
                iR = wk.Cells(wk.Rows.Count, "H").End(xlUp).Row
                If 1 < iR Then
                    iR = iR + 1
                End If
                iMax = .Sheets(i).Cells(.Sheets(i).Rows.Count, "H").End(xlUp).Row
                If 6 < iMax Then
                    For j = 7 To iMax
                        If .Sheets(i).Cells(j, "H").Value <> "" Then
                            .Sheets(i).Rows(j).Copy
                            wk.Cells(iR, 1).PasteSpecial Paste:=xlPasteValues
                            iR = iR + 1
                        End If
                    Next j
                End If
            Next i
            Application.CutCopyMode = False
            .Close
        End With

        cFile = Dir
    Wend

    Application.EnableEvents = True
    Application.ShowWindowsInTaskbar = True
    Application.ScreenUpdating = True
 End Sub
(???) 2015/01/30(金) 17:46

 二人とも仕事が早いなぁ
(稲葉) 2015/01/30(金) 17:47

コメント返信:

[ 一覧(最新更新順) ]


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