[[20221005235030]]　『VBAをつかったデータ抽出方法について教えてほしａx（さな）　ページの最後に飛ぶ

『VBAをつかったデータ抽出方法について教えてほしい』（さな）

VBAをつかったデータ抽出方法について教えてほしい

エクセルに「抽出先シート」、「データ1」、「データ2」というシートがあります。
以下が各シートの特徴です。

「抽出先シート」
・セルC4～C7まで取引先のデータがある
・セルE3～G3に「日付」「No」「取引先」という項目がある

「データ1」
・セルB2～D2に「日付」「No」「取引先」という項目がある
・B3～D9にそれぞれの項目のデータ内容が入っている（行は可変）

「データ2」
データ1と全く同じ

「抽出先シート」の取引先を選択したとき
セルE3～G3に「日付」「No」「取引先」の下セルE4～G4以下にデータ1とデータ2の
該当するセル行を転記するプログラムを組みたいです。

＜使用 Excel：unknown、使用 OS：unknown ＞

ご自身でどこまで挑戦されましたか。
作りかけでも良いので見せてください。
（火災報知器） 2022/10/06(木) 00:21

稚拙ですが、少々お待ちください
（さな） 2022/10/06(木) 00:35

申し訳ございません。
全くわかりません。
途中までです

Sub Sample4()

    '?@シートを変数にセット
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("抽出先")
    Set ws2 = Worksheets("データ1")
    Set ws3 = Worksheets("データ2")

    Dim lastRow As Long
    Dim lastRow2 As Long
    Dim i As Long
    lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow1
        lastRow2 = ws2.Range("B" & Rows.Count).End(xlUp).Row
        ws2.Range("B" & lastRow2 + 1 & ":D" & lastRow2 + 1).Value = ws1.Range("B" & i & ":D" & i).Value
    Next i

    '?Aシートを指定してデータを転記
    ws1.Range("E4:G").Value = ws2.Range("B3:C").Value
    ws1.Range("E4:G").Value = ws3.Range("B3:C").Value

End Sub

（さな） 2022/10/06(木) 00:47

https://www.239-programing.com/cgi-bin/excelvba_bbs.cgi?id=1028
https://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=195292&rev=0
（マルチ） 2022/10/06(木) 00:49

「抽出先シート」の取引先を選択したときこれは「抽出先シートのＧ３セルにカーソルを合わせた時」ですか？
それとも「抽出先シートのＣ４～Ｃ７セルにカーソルを合わせた時」ですか？

選択するデータと抽出するデータに関係性が見えない場合、該当させるのは難しいと思いますが。
（ngk） 2022/10/06(木) 08:41

Sub Sample(ByVal keyword As String)
'VBAをつかったデータ抽出
'「抽出先シート」の取引先を選択したとき
'セルE3～G3に「日付」「No」「取引先」の下
'セルE4～G4以下にデータ1とデータ2の該当するセル行を転記する

'「抽出先シート」
'・セルC4～C7まで取引先のデータがある
'・セルE3～G3に「日付」「No」「取引先」という項目がある
'「データ1」「データ2」
'・セルB2～D2に「日付」「No」「取引先」という項目がある
'・B3～D9にそれぞれの項目のデータ内容が入っている（行は可変）

'シートを変数にセット

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws As Worksheet

    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long

    Set ws1 = Worksheets("抽出先")  '「抽出先シート」
    Set ws2 = Worksheets("データ1") '「データ1」
    Set ws3 = Worksheets("データ2") '「データ2」

    '抽出先（「抽出先シート」のE列）最終行を取得
    lastRow1 = ws1.Range("E" & Rows.Count).End(xlUp).Row
    'データ用シートを巡回
    For Each ws In Worksheets(Array(ws2.Name, ws3.Name))
        With ws
            'データ用シートの最終行を取得
            lastRow2 = .Range("B" & Rows.Count).End(xlUp).Row
            '3行目から最終行まで巡回
            For i = 3 To lastRow2
                'G列の値がkeyword（取引先）と一致したら
                If .Range("D" & i).Value = keyword Then
                    '抽出先行を1加算
                    lastRow1 = lastRow1 + 1
                    '抽出先のE～G列にデータのB～D列を転記
                    ws1.Range("E" & lastRow1 & ":G" & lastRow1).Value = .Range("B" & i & ":D" & i).Value
                End If
            Next
        End With
    Next
End Sub

練習問題のつもりで作成してみました。
さなさんの考えと違ったものでしたらご指摘お願いします。
（下手の横好き） 2022/10/06(木) 10:21

これを「抽出先」シートのシートモジュールに記入

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("C4:C7")) Is Nothing Then    '選択中範囲とC4:C7の範囲が重なっていたら
        Cancel = True                                           'ダブルクリックをキャンセル
        Dim r As Range
        For Each r In Intersect(Target, Range("C4:C7")).Cells   '選択範囲とC4:C7の重複セルについて
            Sample r                                            '抽出を実施
        Next
    End If
End Sub

これを標準モジュールに記入

 Sub Sample(ByVal keyword As String)

'シートを変数にセット

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws As Worksheet

    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long

    Set ws1 = Worksheets("抽出先")  '「抽出先シート」
    Set ws2 = Worksheets("データ1") '「データ1」
    Set ws3 = Worksheets("データ2") '「データ2」

    '抽出先（「抽出先シート」のE列）最終行を取得
    lastRow1 = ws1.Range("E" & Rows.Count).End(xlUp).Row
    'データ用シートを巡回
    For Each ws In Worksheets(Array(ws2.Name, ws3.Name))
        With ws
            'データ用シートの最終行を取得
            lastRow2 = .Range("B" & Rows.Count).End(xlUp).Row
            '3行目から最終行まで巡回
            For i = 3 To lastRow2
                'G列の値がkeyword（取引先）と一致したら
                If .Range("D" & i).Value = keyword Then
                    '抽出先行を1加算
                    lastRow1 = lastRow1 + 1
                    '抽出先のE～G列にデータのB～D列を転記
                    ws1.Range("E" & lastRow1 & ":G" & lastRow1).Value = .Range("B" & i & ":D" & i).Value
                End If
            Next
        End With
    Next
End Sub

一つ前の書き込みは貼り付けるものを間違えてしまいました。
（下手の横好き） 2022/10/06(木) 10:22

コメント返信：

[ 一覧(最新更新順) ]

[[20221005235030]] 『VBAをつかったデータ抽出方法について教えてほしａx（さな） ページの最後に飛ぶ

[[20221005235030]]　『VBAをつかったデータ抽出方法について教えてほしａx（さな）　ページの最後に飛ぶ