質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

2回答

20399閲覧

【内容追記】あるExcelの複数のシートから、特定の値を持つ「行」のみ別のExcelへ抽出したい

morikawa0208

総合スコア27

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

1クリップ

投稿2016/08/25 00:55

編集2016/08/25 08:58

Excelでのマンションの売上管理を行うこととなりました。
今までは1シート1マンションという形で管理しており、全体の数字や予定等を見る際に手間がかかっていました。
これを期に、データベースのような形で1つのExcelに抽出したいと思っています。

###前提・実現したいこと
・複数シート上の該当する行のみ、別Excelに抽出したい
(自動ではなく、「転送」ボタン押したら等、ワンアクションありでも可)

###試したこと
今まではできないと思っていたので、入力した際に手動でコピペしていました。
最近VBA等を触るようになり、特定の値を持たせて対象とすれば
抽出できるのでは・・・と思い質問させていただきました。

###補足情報(言語/FW/ツール等のバージョンなど)
Excel2013、対象シートは変動しますが25~30ほど
1シート1物件、1行に1部屋の情報を入力しています。
管理項目は全物件同じなのですが、計算方法がそれぞれ異なってくるため、1シートにまとめられない状況です。
各シートにはあらかじめ販売金額等を記載しており、契約が決まった際に契約者等を記入すると、
その契約で得られる仲介手数料等が算出される形となります。

私の勉強不足によりおかしな質問をしているかもしれませんが、何卒よろしくお願いいたします。

###途中経過
ご回答いただいた方々のおかげで、元シートをコピー後、別ブックへの書き込みは
できるようになりました。
ただ、複数行が対象となった場合に、貼付けの動作が1行の中でループしてしまいます。
(言葉で伝わるか微妙なところですが)

98%回答いただいたコードですが以下のコードです。
【やりたいこと】
対象となった行を別ブックに貼付け、次の対象となった行はその下に貼付ける 以後繰り返し

Sub 書きかけ() Dim i As Integer i = 1 Dim sht As Worksheet Dim rng As Range Dim lastRow As Long '現在のブック内にあるすべてのシートをループ処理 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列が1なら、その行をコピー If sht.Cells(rng.Row, 1) = 1 Then sht.Rows(rng.Row).Copy 'DBブックを選択し、一番下の行を選択 Windows("VBAテスト.xlsx").Activate lastRow = 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

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

ベストアンサー

わからない点

データベースのような形で1つのExcelに抽出したい

というのは、データを一元管理できるようなシートを作成したいということでしょうか?

計算方法がそれぞれ異なってくるため、1シートにまとめられない

という記載もされている為、実現したい機能が何のための機能なのか掴みきれませんでした。

最終的なデータの管理の仕方はどんなものを想定していますか?

①既存のシート構成(1シート1マンション)をそのまま利用する。データ抽出が必要なときは各シートから対象データを探して別シートに抽出する。
⇒実現したい機能はデータ抽出のための機能

②既存のデータを一元管理できるよう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

実行環境がないため、エラー等あるかもしれません。参考までに。

投稿2016/08/25 02:06

編集2016/08/26 04:38
jawa

総合スコア3013

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

morikawa0208

2016/08/25 03:56

お忙しい中、こちらの意図まで汲み取ってもらいつつ、ご回答いただきありがとうございます( ; ; ) >①既存のシート構成(1シート1マンション)をそのまま利用する。データ抽出が必要なときは各シートから対象データを探して別シートに抽出する。 ⇒実現したい機能はデータ抽出のための機能 >②既存のデータを一元管理できるよう1シートにまとめて管理する。データ抽出が必要なときはこのシートからデータを探して別シートに抽出する。 ⇒実現したい機能はデータベース的なシートを作るための機能 正に上記書いていただいた通り、データベース化して、全件対象とした管理資料を簡単に出したいためでした。 まだ別作業中で書いていただいたコード試せていないですが、今日中に確認したいと思います! ありがとうございます。
jawa

2016/08/26 04:38

今回やろうとしていることが①なのか②なのか、やはりよくわからないですね・・; とりあえず追記いただいたコードに対しての指摘をあげさせていただきましたのでご確認ください。
morikawa0208

2016/08/26 05:09

日本語読まずコメント回答しておりました・・・ 正確には②のデータベース作成を行いたかったのです。 作成後は②のデータを基にして①のような必要情報の抽出を行いたいという内容でした。 (抽出はひとまずフィルターや詳細設定で・・・) そして、ご提示いただいたコードで無事動きました!ありがとうございます>< 取り急ぎ貼り付けて動作確認しただけなので、内容の把握まではできていませんが この処理ができるようになると他の処理も楽になるので大変助かりました。 まだまだこの後実装したい機能はあるのですが、質問させていただいた内容は おかげさまで解決いたしましたので、ベストアンサーとさせていただきます。 本当にありがとうございました!
guest

0

基本的な構成のみ作ってみました。
データがあるブックとは別のブックに下記マクロを登録して実行してください。
このサンプルでは仮に、A列の値が1の行を抽出しています。
参考まで。

VBA

1Sub sample() 2 3 Dim bk As Workbook ' 抽出元のブック 4 Dim fs As Worksheet ' 抽出元のシート 5 Dim ts As Worksheet ' 抽出先のシート(このシート) 6 Dim fr As Long ' 抽出元の行カウンタ 7 Dim tr As Long ' 抽出先の行カウンタ 8 9 ' このシートを保持 10 Set ts = ActiveSheet 11 12 ' 抽出元ブックを開く 13 Set bk = Workbooks.Open("c:\temp\sample.xlsx") 14 15 tr = 1 16 17 ' ブック内のシート分ループ 18 For Each sh In bk.Worksheets 19 r = 1 20 ' 登録されている行を対象にループ 21 While sh.Cells(r, 1) <> "" 22 ' 抽出対象か? 23 If sh.Cells(r, 1).Value = 1 Then 24 ' 行を丸ごとコピー 25 sh.Rows(r).Copy ts.Rows(tr) 26 tr = tr + 1 27 End If 28 r = r + 1 29 DoEvents 30 Wend 31 Next 32 33 ' ブックを閉じる 34 bk.Close 35 36End Sub 37

投稿2016/08/25 02:28

ttyp03

総合スコア16996

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

morikawa0208

2016/08/25 03:45

お忙しい中、ご回答ありがとうございます! 読む分には「この処理してるんだな」というのがぼんやり分かるんですが、自分で書くとなるとまだまだぜんぜんピンとこないですね… 勉強させてもらいます!ありがとうございます!
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問