[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数のブックを開き、該当シートを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.