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

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

ただいまの
回答率

90.40%

  • VBA

    1968questions

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

  • Excel

    1689questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

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

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 1
  • VIEW 8,056

morikawa0208

score 18

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
  • 気になる質問をクリップする

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+1

わからない点

>データベースのような形で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 12:56

    お忙しい中、こちらの意図まで汲み取ってもらいつつ、ご回答いただきありがとうございます( ; ; )

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

    >②既存のデータを一元管理できるよう1シートにまとめて管理する。データ抽出が必要なときはこのシートからデータを探して別シートに抽出する。
    ⇒実現したい機能はデータベース的なシートを作るための機能

    正に上記書いていただいた通り、データベース化して、全件対象とした管理資料を簡単に出したいためでした。
    まだ別作業中で書いていただいたコード試せていないですが、今日中に確認したいと思います!

    ありがとうございます。

    キャンセル

  • 2016/08/26 13:38

    今回やろうとしていることが①なのか②なのか、やはりよくわからないですね・・;

    とりあえず追記いただいたコードに対しての指摘をあげさせていただきましたのでご確認ください。

    キャンセル

  • 2016/08/26 14:09

    日本語読まずコメント回答しておりました・・・
    正確には②のデータベース作成を行いたかったのです。
    作成後は②のデータを基にして①のような必要情報の抽出を行いたいという内容でした。
    (抽出はひとまずフィルターや詳細設定で・・・)

    そして、ご提示いただいたコードで無事動きました!ありがとうございます><
    取り急ぎ貼り付けて動作確認しただけなので、内容の把握まではできていませんが
    この処理ができるようになると他の処理も楽になるので大変助かりました。

    まだまだこの後実装したい機能はあるのですが、質問させていただいた内容は
    おかげさまで解決いたしましたので、ベストアンサーとさせていただきます。
    本当にありがとうございました!

    キャンセル

0

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

Sub sample()

    Dim bk As Workbook  ' 抽出元のブック
    Dim fs As Worksheet ' 抽出元のシート
    Dim ts As Worksheet ' 抽出先のシート(このシート)
    Dim fr As Long      ' 抽出元の行カウンタ
    Dim tr As Long      ' 抽出先の行カウンタ

    ' このシートを保持
    Set ts = ActiveSheet

    ' 抽出元ブックを開く
    Set bk = Workbooks.Open("c:\temp\sample.xlsx")

    tr = 1

    ' ブック内のシート分ループ
    For Each sh In bk.Worksheets
        r = 1
        ' 登録されている行を対象にループ
        While sh.Cells(r, 1) <> ""
            ' 抽出対象か?
            If sh.Cells(r, 1).Value = 1 Then
                ' 行を丸ごとコピー
                sh.Rows(r).Copy ts.Rows(tr)
                tr = tr + 1
            End If
            r = r + 1
            DoEvents
        Wend
    Next

    ' ブックを閉じる
    bk.Close

End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/08/25 12:45

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

    キャンセル

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

  • ただいまの回答率 90.40%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る

  • VBA

    1968questions

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

  • Excel

    1689questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • トップ
  • VBAに関する質問
  • 【内容追記】あるExcelの複数のシートから、特定の値を持つ「行」のみ別のExcelへ抽出したい