[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『項目ごとにブックを作成』（すいか）
お世話になっております。
同一フォルダ内にあるブック全てを開き、項目ごとにフィルターをかけて
コピーしたものをその項目名で名前を付けて保存を行いたいです。
しかし、1つ目の項目で処理が完了してしまいます。
イメージ
1ブックの中にAからFの項目がついたデータがあります。
2フィルターでAからCのデータを全てのブックからコピーし、集計シートへ貼り付け
3その集計シートをコピーし、「A」から「C」とそれぞれ名前を付けて保存
←ここでAのブックのみブックを作成し処理が完了します。
ご教示お願い致します。
Sub 項目ごとにブックを作成()
Dim i As Long
Dim bookname As String
Dim myfld As String
Dim FilterData As String
myfld = ThisWorkbook.Path
bookname = Dir(myfld & "\*.xlsx")
For i = 2 To Sheets("リスト").Cells(Rows.Count, 2).End(xlUp).Row
FilterData = Sheets("リスト").Cells(i, 2)
Do While bookname <> ""
Workbooks.Open myfld & "\" & bookname
ActiveWorkbook.Sheets("結果").Range("A1").AutoFilter field:=2, Criteria1:=FilterData
Range("A1").CurrentRegion.Offset(1, 1).Copy
ThisWorkbook.Sheets("集計").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
bookname = Dir()
Loop
ThisWorkbook.Sheets("集計").Copy
ActiveWorkbook.SaveAs Filename:=myfld & "\" & FilterData & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
i = i + 1
ThisWorkbook.Sheets("集計").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Next
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
これをDirのループの外に移動させないとだめなのでは？
（マナ） 2019/08/13(火) 19:13
これは何のためにありますか？
（マナ） 2019/08/13(火) 19:15
（マナ） 2019/08/13(火) 19:18
まずは、どんな処理順番になるか
箇条書きに書き出すとよいと思います。
↓をもっと詳細にするという意味です。
＞1ブックの中にAからFの項目がついたデータがあります。
＞2フィルターでAからCのデータを全てのブックからコピーし、集計シートへ貼り付け
＞3その集計シートをコピーし、「A」から「C」とそれぞれ名前を付けて保存
（マナ） 2019/08/13(火) 19:44
1 全ブック内にあるA項目をフィルターをかけコピー
2 コピーしたものをシート「集計」に貼り付け
3 シート「集計」をコピーし、Aと名前を付けて保存
4 全ブック内にあるB項目をフィルターをかけコピー
5 以下2-3を繰り返し、Cまで完了する。
＞i=i+1
For〜nextにあわせようと入れました。
（すいか） 2019/08/13(火) 20:07
1.ブックを開く 2.とりあえず全データを集計シートにコピペ 3.ブックを閉じる
4.集計シートにオートフィルタを設定する 5.Aで抽出する 6.新規ブックを追加して、5をコピペする 7.貼付終わったブックを、名前を付けて保存する 8.新規ブックを閉じる
9.5〜8をCに読み替えて実行する
みたいに考えてみてはどうでしょうか？
（もこな２） 2019/08/13(火) 20:16
１）*.xlsxを開く ２）結果シートのデータをマクロブックの集計シートに転記 ３）１）のxlsxを閉じる ４）１）〜３）を全てのxlsxで繰り返す。 ５）集計シートを新規ブックにコピー ６）「A以外」を抽出し削除 ７）名前を付けて保存 ８）閉じる ９）５）〜８）をリストにある全項目で繰り返す
（マナ） 2019/08/13(火) 20:25
そんなことしてはいけません。
自動で１ずつ加算されます。
（マナ） 2019/08/13(火) 20:34
たとえば、↓のようにすれば、マクロを記述したブック以外は、用が済んだら閉じることができます。
Sub 項目ごとにブックを作成_研究用()
Dim dstRNG As Range
Dim srcRNG As Range
Dim tmp As Long
Dim buf As Variant
Dim bookname As String
Stop '←ブレークポイントのかわり
With ThisWorkbook.Sheets("集計")
.Cells.Delete
Set dstRNG = .Range("A1")
'▼集計シートに集積するループ---------------------------------
bookname = Dir(ThisWorkbook.Path & "\*.xls?")
Do While bookname <> ""
If bookname <> ThisWorkbook.Name Then
With Workbooks.Open(ThisWorkbook.Path & "\" & bookname)
.Worksheets("結果").UsedRange.Offset(tmp).Copy dstRNG
.Close
End With
tmp = 1 '２つ目のブックから項目行はコピーしない
Set dstRNG = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End If
bookname = Dir()
Loop
'▲----------------------------------------------------------
'▼項目毎に抽出（して別ブックに貼付&保存）するループ---------
For Each buf In Array("A", "C")
.Range("A1").AutoFilter Field:=2, Criteria1:=buf
Set srcRNG = .AutoFilter.Range
With Workbooks.Add
srcRNG.Copy
.Worksheets(1).Name = "集計"
.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
.SaveAs _
Filename:=ThisWorkbook.Path & "\" & buf, _
FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next buf
'▲----------------------------------------------------------
End With
Application.CutCopyMode = False
End Sub
（もこな２） 2019/08/13(火) 21:21
宜しくお願い致します。
＞もこな2さん
研究用ありがとうございます。
（すいか） 2019/08/13(火) 22:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.