[[20121116110548]]　『VBA　複数シートからの検索及びデータ抽出』（フィン）　ページの最後に飛ぶ

『VBA　複数シートからの検索及びデータ抽出』（フィン）

EXCEL2003を使用している初心者です。お力を貸してくださいm(__)m

1～12までのシートがあり、同じ見出しでﾃﾞｰﾀｰが入っています。

・sheet1
　　　　 A列　　B列　　C列　　 D列
　　1　　日付　番号　品物　　金額
　　2　　1/1　　A　　りんご　　100
　　3　　1/1　　B　　みかん　　 50　　
　　4　　1/2　　C　　いちご　　300
　　5　　1/4　　A　　りんご　　200

・sheet2
　　　　 A列　　B列　　C列　　 D列
　　1　　日付　番号　品物　　金額
　　2　　2/1　　D　　なし　　　100
　　3　　2/2　　A　　りんご　 250　　
　　4　　2/20　 C　　いちご　　300
　　5　　2/26　 B　　みかん　　200

という風にsheet12までデーターが入力されており、
検索シートのA1セルにAと入力すると、B1セルにりんごと品物名が表示され
4行目以降にAのりんごのﾃﾞｰﾀｰを抽出したいです。↓

・検索シート
　　　　 A列　　B列　　C列　　 D列
　　1　　 A　　りんご　　　　　　　　　　・・・A1にAと入力すると、B1に商品名
　　2　　　　
　　3　　日付　番号　品物　　金額
　　4　　1/1　　A　　りんご　　100　　　・・・4行目以降に1～12ｼｰﾄからAのﾃﾞｰﾀを
　　5　　1/4　　A　　りんご　　200　　　　　　　すべて抽出したい
　　6　　2/2　　A　　りんご　 250　　

どうしたらこの様な検索および抽出ができるでしょうか？
よろしくお願いしますm(__)m

 まず、A と　りんご　は　１：１　？
 あるシートでは A　が　りんご、別のシートでは　A が　みかん　とかは絶対にない？
 というか、りんご　で検索するのではなく A で検索かな？

 方法としてはオートフィルターやフィルターオプション。
 各シートを回しながら、抽出して検索シートに転記する方法もあるし、こっそりと作業シートをつくって
 そこに検索シート以外のデータをいったん集約して、そこから一発でフィルターという方法も。

 (ぶらっと)

ぶらっとさん、早速のお返事ありがとうございますm(__)m

Aはりんご　Bはみかん　Cはいちご・・・と決まっています。
B列の番号での検索をしたいです。

実際は各ｼｰﾄ　1万行ほどのﾃﾞｰﾀｰがあります。なので集約してフィルタは難しいかと思います。

よろしくお願いしますm(__)m

（フィン）

 >実際は各ｼｰﾄ　1万行ほどのﾃﾞｰﾀｰがあります

 なるほど。2003なら、ちょっと厳しいかな。
 とりあえず、集約版を書いてみたので参考まで。
 (少ないデータ数のブックで、イメージが間違ってないかを試してみてほしい）

 後程、シートごとの処理版をアップ予定。

 検索シートのシートモジュールに。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dSh As Worksheet
    Dim wSh As Worksheet
    Dim flag As Boolean
    Dim i As Long
    Dim myR As Range
    Dim myNum As String

    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    myNum = Range("A1").Value
    If Len(myNum) = 0 Then Exit Sub 'クリアされた時

    Application.ScreenUpdating = False
    '作業シートを作成
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set wSh = ActiveSheet
    '各シートから作業シートにデータ集約
    For Each dSh In Worksheets
        If Not dSh Is Me And Not dSh Is wSh Then
            Set myR = dSh.Range("A1").CurrentRegion
            If flag Then
                Set myR = myR.Resize(myR.Rows.Count - 1).Offset(1)
                i = wSh.UsedRange.Rows.Count + 1
            Else
                flag = True
                i = 1
            End If
            myR.Copy wSh.Cells(i, "A")
        End If
    Next

    'フィルタリング
    Application.EnableEvents = False

    Me.Range(Me.Range("A1"), Me.UsedRange).Offset(2).ClearContents

    With wSh
        .Range("A1").AutoFilter Field:=2, Criteria1:=myNum
        If WorksheetFunction.Subtotal(103, .Columns("A")) < 2 Then
            MsgBox "検索対象データはありません"
        Else
            .AutoFilter.Range.Copy Me.Range("A3")
            Me.Range("B1").Value = Me.Range("C4").Value
        End If
    End With

    Application.EnableEvents = True

    '作業シートを削除
    Application.DisplayAlerts = False
    wSh.Delete
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

 End Sub

 各シートごとのフィルター版。
 同じく検索シートのシートモジュールに。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dSh As Worksheet
    Dim flag As Boolean
    Dim i As Long
    Dim myR As Range
    Dim myNum As String

    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    myNum = Range("A1").Value
    If Len(myNum) = 0 Then Exit Sub 'クリアされた時

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    '抽出領域のクリア
    With Me.UsedRange
        .Resize(.Rows.Count - 2).Offset(2).ClearContents
    End With

    '各シートごとにフィルタリング
    For Each dSh In Worksheets
        If Not dSh Is Me Then
            With dSh
                .AutoFilterMode = False
                .Range("A1").AutoFilter Field:=2, Criteria1:=myNum
                '抽出データがあれば転記
                If WorksheetFunction.Subtotal(103, .Columns("A")) > 1 Then
                    If flag Then
                        Set myR = .AutoFilter.Range.Offset(1)
                        i = Me.Range("A" & Me.Rows.Count).End(xlUp).Offset(1).Row
                    Else
                        Set myR = .AutoFilter.Range
                        flag = True
                        i = 3
                    End If
                    myR.Copy Me.Range("A" & i)
                    .AutoFilterMode = False
                End If
            End With
        End If
    Next

    Me.Range("B1").Value = Me.Range("C4").Value

    Application.EnableEvents = True
    Application.ScreenUpdating = True

 End Sub

 (ぶらっと)

ぶらっと様　ありがとうございますm(__)m

すごいです！やりたいイメージとピッタリです！

ただ始めにご回答頂いたマクロで、実際のデーターで試してみたのですが
データーが多すぎるからかエラーで止りますm(__)m

現状は作業シートが作られ、そこに各シートのデーターがすべて貼りついているから
それでデーター件数が多いからエラーになるのでしょうか？
（フィン）

色々試してみたのですが、データー数が多く上手くいきません。
勉強不足で申し訳ございません。
ご教授お願いしますm(__)m
（フィン）

 >データーが多すぎるからかエラーで止りますm(__)m

 最初の作業シート版だね？　データが多いようなので使えないだろうと判断したんだけど。
 実際のエラーコード（メッセージ）は、どんなものだった？で光っているコードはどこだった？
 きっと、作業シートに貼り付けようとして行が 65636行を超えてしまったんだと思うけど。

 いずれにしても、２回目にアップしたコードで試してみて。

 >色々試してみたのですが、データー数が多く上手くいきません。

 これは、最初のコード？　それとも後のコード？
 うまくいかないというのはエラーということ？　抽出がうまくいかないということ？

 (ぶらっと)

上記の例のような少ないデーターでは、どちらも上手くいきました。

実際の大量にあるデーターは、最初のコードで試してみました。

エラーコードは1004
コピー領域と貼付領域が違うため貼付出来ません。というメッセージです。
ぶらっとさんがおっしゃる通り、65636行を越えたからだと思います。

光っている箇所は
myR.Copy wSh.Cells(i, "A")

なんとかコードを変更し、最初のコードで上手く動いてくれたのですが、上記のエラーで
止ります。2つ目のコードは自分が変更する箇所が間違っているようで上手く動かないので
できれば最初のコードで出来たらと思っています。

ちなみにシート1～12の間に6の後に集計シートが入っているのですが、そのシートを飛ばして
抽出する事は可能でしょうか？
（フィン）

 >コピー領域と貼付領域が違うため貼付出来ません。というメッセージです。 
 >ぶらっとさんがおっしゃる通り、65636行を越えたからだと思います。

 だろうね。で、これは直接的には解決方法はないね。65536超は（2003では）おさまらないので。
 やるとすれば、コピペの前に、残り行数を調べて、足りなければ作業シートも追加して、そちらにコピペして
 最後のフィルタリングは、できあがっている作業シートをすべて対象にする？

 それをやるくらいなら２番目のコードでやるのがいいんじゃないかな？
 ただし、２番目のコードにしても抽出結果が65536を超えればエラーになるけどね。

 >ちなみにシート1～12の間に6の後に集計シートが入っているのですが、そのシートを飛ばして 
 >抽出する事は可能でしょうか？

 たとえば１番目のコードで言えば

 If Not dSh Is Me And Not dSh Is wSh Then

 ここで、検索シートと作業シートを除いている。
 ここに、除きたい他のシートも、いくつでも追加できるよ。

 (ぶらっと)

 最初、あまり深く考えないまま作業シートへの集約のコードをアップしたけど、後からアップした方式と比較すると。

 最初のコード
 ・１２シートの内容を作業シートのコピペ（１２回）　★１
 ・オートフィルター実行（１回）
 ・フィルターされた内容を検索シートにコピペ（１回）

 後のコード
 ・オートフィルター実行（１２回）
 ・フィルターされた内容を検索シートにコピペ（１２回）★２

 確かに、後のコードはオートフィルター回数が多い。
 だけど、その処理はエクセル機能で行うので負荷はあまりかからない。
 一方、コピペ回数は、最初のコードが１３回。後のコードは１２回。
 かつ、★１は元データのすべての行、★２はフィルターされた分のみなので
 コピペ負荷は、圧倒的に後のコードが小さい。

 ましてや（？）65536の制限で作業シートを増やしたとすれば、最初のコードでの
 オートフィルター回数も増えるし、その結果のコピペ回数も増える。
 コードも、結局は複数シートのオートフィルターということになるので、後のコードと
 (コード的には）かわらなくなる。なにより、作業シートを生成して、そこに集約する部分が
 後のコードと比べて、【余計】なものとして存在。

 やっぱり、後のコードでいったほうがいいねぇ。

 (ぶらっと)

コメント返信：

[ 一覧(最新更新順) ]

[[20121116110548]] 『VBA 複数シートからの検索及びデータ抽出』（フィン） ページの最後に飛ぶ

[[20121116110548]]　『VBA　複数シートからの検索及びデータ抽出』（フィン）　ページの最後に飛ぶ