質問: sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1 '値で貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Next rng Next sht End Sub ```
回答: わからない点 >データベースのような形で1つのExcelに抽出したい というのは、データを一元管理できるようなシートを作成したいということでしょうか? >計算方法がそれぞれ異なってくるため、1シートにまとめられない という記載もされている為、実現したい機能が何のための機能なのか掴みきれませんでした。 最終的なデータの管理の仕方はどんなものを想定していますか? 1既存のシート構成(1シート1マンション)をそのまま利用する。データ抽出が必要なときは各シートから対象データを探して別シートに抽出する。 ⇒実現したい機能はデータ抽出のための機能 2既存のデータを一元管理できるよう1シートにまとめて管理する。データ抽出が必要なときはこのシートからデータを探して別シートに抽出する。 ⇒実現したい機能はデータベース的なシートを作るための機能 もう少し期待する動作の具体例(シート構成や簡単なサンプルデータ、処理前後の状態など)があると回答しやすいです。 とりあえず ブック内のすべてのシートをループ処理するサンプルを提示します。 ``` Dim i As Integer i = 1 Dim sht As Worksheet Dim rng As Range '現在のブック内にあるすべてのシートをループ処理 For Each sht In ActiveWorkbook.Worksheets '対象シート内のA列先頭からA列最終データ行までをループ処理 For Each rng In sht.Range(sht.Cells(1, 1), sht.Cells(sht.Rows.Count, 1).End(xlUp)) 'A列が○なら If sht.Cells(rng.Row, 1) = "○" Then 'O列に連番をセット sht.Cells(rng.Row, 15) = i '番号をインクリメント i = i + 1 End If Next Next ``` 追加で記載いただいたコードについて 今手元に動作確認できる環境がないので未確認での指摘です。すみません。 まず、`Windows("VBAテスト.xlsx").Activate`の部分について。 最初に「ActiveWorkbookの全シート」を対象にループ処理していますが、そのループの最中に「別のブックをアクティブ化」してしまうことになります。 動作させてみないとわかりませんが、そんなことをして最初のループが正しく継続されるかが心配です。 次に、 `lastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1` の部分ですが、おそらく出力ブックの最終行から次の出力位置を取得したいのだと思いますが、shtは読取ブック内のシートです。 最後に `Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False` の部分ですが、`Selection`は現在のアクティブシート上で選択されているセル(またはオブジェクト)を意味します。 これ以前に `Windows("VBAテスト.xlsx").Activate` でブックはアクティブ化していますが、出力先のシートや対象セルは指定していないので「たまたまそのブックで選択されているセルに出力する」ような動作になってしまうと思います。 せっかくlastRowを取得していますがこれも利用していません。 貼り付け先を指定したコピー&ペーストにするか、もしくはSelectionを使うなら事前に貼り付けるセルをSelectする必要があります。 以上をまとめると以下のようなコードになると思います。 ``` Sub 書きかけ() Dim wbRead As Workbook Dim wbOut As Workbook Dim shtRead As Worksheet Dim shtOut As Worksheet Set wbRead = ActiveWorkbook Set wbOut = Workbooks("4.xls") Set shtOut = wbOut.Worksheets("Sheet1") Dim rng As Range Dim lastRow As Long '現在のブック内にあるすべてのシートをループ処理 For Each shtRead In wbRead.Worksheets '対象シート内のA列先頭からA列最終データ行までをループ処理 For Each rng In shtRead.Range(shtRead.Cells(1, 1), shtRead.Cells(shtRead.Rows.Count, 1).End(xlUp)) 'A列が1なら、その行をコピー If shtRead.Cells(rng.Row, 1) = 1 Then '読込シートから行コピー shtRead.Rows(rng.Row).Copy 'DBブックを選択し、一番下の行番号を取得 lastRow = shtOut.Cells(shtOut.Rows.Count, 1).End(xlUp).Row + 1 '出力シートに値で貼り付け shtOut.Rows(lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Next rng Next shtRead End Sub ``` 実行環境がないため、エラー等あるかもしれません。参考までに。