Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
フィルターで可視化されている部分をVlookup関数を使いたい
投稿日時: 18/03/22 17:05:28
投稿者: coin

16行目にフィルターをかけて、他のファイルとVLookupで検索を行おうかと思っています。
可視化されているものだけを、VLookupをしようかと思っていますが、上手く出来ません。
 
Loopで回そうかと思っていますが、どのようにしたらよろしいでしょうか。
 
現在、以下の通りにやっております。
 
    Set ws = Workbooks(MMDD & ".xlsx").Worksheets(1) このファイルにあるデータをVlookup
     
    Workbooks(wb3).Activate 作業をしたいファイルです。
    With Worksheets(1)
        If .AutoFilterMode Then
            If .AutoFilter.Filters(16).On Then フィルターをかけているのが16番目なので、このようにしました。
                myR = .AutoFilter.Range.Rows.Count 該当のカウントを数えました。
            End If
        End If
    End With
 
    intRow = 3
    Do Until intRow = myR
 
    With Worksheets(1)
        If .AutoFilterMode Then
            If .AutoFilter.Filters(16).On Then
                myR = .AutoFilter.Range.Rows.Count
                myC = .AutoFilter.Range.Cells(13).Column Vlookupを入れたいセル番地を指定。
                myC1 = .AutoFilter.Range.Cells(14).Column Vlookupを入れたいセル番地を指定。
                .Range("M" & myC) = Application.VLookup(Cells(intRow, 3), ws.Range("C2:K" & r), 5, False)
                .Range("N" & myC1) = Application.VLookup(Cells(intRow, 3), ws.Range("C2:K" & r), 9, False)
            End If
        End If
    End With
  intRow = intRow + 1
    Loop
 
このようにすると、最初のところだけしか設定できません。
可視化されている所全てを行うには、この方法では無理なのでしょうか。
 
 

回答
投稿日時: 18/03/22 18:04:50
投稿者: WinArrow
投稿者のウェブサイトに移動

確認
 
>16行目にフィルターをかけて
16列目では?

回答
投稿日時: 18/03/22 20:29:39
投稿者: WinArrow
投稿者のウェブサイトに移動

 

引用:
myC = .AutoFilter.Range.Cells(13).Column Vlookupを入れたいセル番地を指定。

で取得した「値」(列番号)を
 
.Range("M" & myC)
で使っているが、
 
.Range("M" & myC)
の「myC」は、行番号ですが・・・・
 

回答
投稿日時: 18/03/22 20:35:42
投稿者: WinArrow
投稿者のウェブサイトに移動

オートフィルタの可視セルを取得するサンプルコードです。
 
 
Sub test()
Dim sht As Worksheet, Cx As Long, Rx As Long
Dim myCell As Range
 
Set sht = ActiveSheet
For Cx = 1 To sht.UsedRange.Columns.Count
    If sht.AutoFilter.Filters(Cx).On Then
        Set myCell = sht.AutoFilter.Range.Columns(Cx).SpecialCells(xlCellTypeVisible)
        Debug.Print myCell.Address
        Exit For
    End If
Next
End Sub

投稿日時: 18/03/23 08:42:17
投稿者: coin

WinArrowさん
 
色々とすみません。
ご指摘ありがとうございます。
サンプルコードを元に、もう一度考えてみます。
 
完成したら、報告します。
無理だったら、もう一度相談させて下さい。
 

回答
投稿日時: 18/03/23 14:08:57
投稿者: もこな2

私も偉そうなことは言えるほどの実力はないですが、とりあえずは、ご呈示のコードについて回答者が検証できるように、コンパイルエラーが出ない程度まではチェックすべき(仕上げる)べきではないかとおもいますが。。。
 
想像込みで整理するとこんな感じでしょうか・・・・

引用:
Sub 整理()
    Const MMDD As String = "ダミーsrc"
    Const wb3 As String = "出力テスト.xlsx"
    Dim ws As Worksheet
        'このファイルにあるデータをVlookup
        Set ws = Workbooks(MMDD & ".xlsx").Worksheets(1)
    Dim intRow As Long, myR As Long
    Dim myC As Long, myC1 As Long, R As Long
 
    '作業をしたいファイルです。
    Workbooks(wb3).Activate
    With Worksheets(1)
        If .AutoFilterMode Then
            'フィルターをかけているのが16番目なので、このようにしました。
            If .AutoFilter.Filters(16).On Then
                '該当のカウントを数えました。
                myR = .AutoFilter.Range.Rows.Count
            End If
        End If
    End With
 
    intRow = 3
    Do Until intRow = myR
 
    With Worksheets(1)
        If .AutoFilterMode Then
            If .AutoFilter.Filters(16).On Then
                myR = .AutoFilter.Range.Rows.Count
 
                'Vlookupを入れたいセル番地を指定。
                myC = .AutoFilter.Range.Cells(13).Column
                myC1 = .AutoFilter.Range.Cells(14).Column
 
                .Range("M" & myC) = _
                    Application.VLookup(Cells(intRow, 3), ws.Range("C2:K" & myR), 5, False)
                .Range("N" & myC1) = _
                    Application.VLookup(Cells(intRow, 3), ws.Range("C2:K" & myR), 9, False)
            End If
        End If
    End With
    intRow = intRow + 1
    Loop
End Sub

回答
投稿日時: 18/03/23 15:52:10
投稿者: もこな2

すみません。再度コードを読み直して・・・
↑の赤字部分は、Rでよいのかもしれません。

投稿日時: 18/03/23 16:33:21
投稿者: coin

もこな2さん
 
質問の仕方が悪く本当にすみません。
もこな2さんが書かれている通りです。
ご丁寧にありがとうございます。
 
まだ、試行錯誤中。
自力で努力しないとVBAも覚えないので、とにかく頑張ってやてみようかと思っています。
 
でも、ダメな場合は、アドバイスを頂けると助かります。
宜しくお願い致します。

投稿日時: 18/03/23 17:03:12
投稿者: coin

WinArrow さんの引用:
オートフィルタの可視セルを取得するサンプルコードです。
 
 
Sub test()
Dim sht As Worksheet, Cx As Long, Rx As Long
Dim myCell As Range
 
Set sht = ActiveSheet
For Cx = 1 To sht.UsedRange.Columns.Count
    If sht.AutoFilter.Filters(Cx).On Then
        Set myCell = sht.AutoFilter.Range.Columns(Cx).SpecialCells(xlCellTypeVisible)
        Debug.Print myCell.Address
        Exit For
    End If
Next
End Sub

やっていることが理解する事が出来ました。
 
複数表示。
例えば、71行目〜75行目がフィルターがかかっている場合は、$P$71:$P$75というように表示されています。
これを、一つ一つ分解することはできないのでしょうか。
SpecialCells(xlCellTypeVisible)ここの命令を変更する
 
自力でも調べたいと思いますが、ヒントがあれば教えて下さい。
 
すみませんが、宜しくお願いします。

回答
投稿日時: 18/03/23 17:39:53
投稿者: もこな2

coin さんの引用:
例えば、71行目〜75行目がフィルターがかかっている場合は、$P$71:$P$75というように表示されています。
これを、一つ一つ分解することはできないのでしょうか。

分解というか、1つずつ取り出して処理してあげればよいとおもいます。
 
集団から1つずつ取り出して処理ならば、「For Each 〜 Next ステートメント」が役に立つとおもいますので、調べてみてはいかがでしょうか。
 
また、ちょっと私も頭の体操にコードを考えてみたので投稿します。
(とんでもない動きをするかもしれないので、試すなら別ファイルを作って試すことを強く推奨)
<参考>
http://officetanaka.net/excel/vba/tips/tips155d.htm
 
Sub 整理2()
    Dim データ範囲 As Range
    Dim Target As Range

    'データ範囲のセット(Vlookup関数の”範囲”)
    With Workbooks("ダミーsrc.xlsx").Worksheets(1)
        Set データ範囲 = Intersect( _
            .Range(.Rows(2), .Rows(.UsedRange.Rows(.UsedRange.Rows.Count).Row)), _
            .Columns("C:K"))
    End With


    With Workbooks("出力テスト.xlsx").Worksheets(1)
        'オートフィルタが設定されていたらフィルタ状態をリセットするために一旦解除
        If .AutoFilterMode Then .AutoFilterMode = False

        'A1セルを含む表範囲をターゲットにする。
        With .Range("A1").CurrentRegion

            'オートフィルタを(再)設定 & 16列目で条件抽出
            .AutoFilter Field:=16, Criteria1:="〇〇"

            '表示されている行、かつ、表範囲の16列目に該当するセル集団を対象に1つずつ処理
            For Each Target In Intersect(.SpecialCells(xlCellTypeVisible), .Columns(16))
                With Target
                    'M列(列番号=13)にC列の値をキーにVlookupを実行して結果を出力
                    .Offset(0, -3).Value = _
                        Application.VLookup(.Offset(0, -13), データ範囲, 5, False)

                    'N列(列番号=14)にC列の値をキーにVlookupを実行して結果を出力
                    .Offset(0, -2).Value = _
                        Application.VLookup(.Offset(0, -13), データ範囲, 9, False)
                End With
            Next Target
        End With
    End With

End Sub

回答
投稿日時: 18/03/23 17:50:05
投稿者: WinArrow
投稿者のウェブサイトに移動

>これを、一つ一つ分解することはできないのでしょうか。
 
ヒント野コード
Sub test()
 Dim sht As Worksheet, Cx As Long, Rx As Long
 Dim myCells As Range, myCELL As Range
   
 Set sht = ActiveSheet
 For Cx = 1 To sht.UsedRange.Columns.Count
     If sht.AutoFilter.Filters(Cx).On Then
         Set myCells = sht.AutoFilter.Range.Columns(Cx).SpecialCells(xlCellTypeVisible)
         For Each myCELL In myCells
             Debug.Print myCELL.Address
         Next
         Exit For
     End If
 Next
 End Sub

回答
投稿日時: 18/03/24 13:24:04
投稿者: WinArrow
投稿者のウェブサイトに移動

推測ですが、サンプルコードを書いてみました。
 
Sub Sample1()
Dim Cx As Long, Ws As Worksheet, wb3 As Workbook
Dim myCells As Range, myCELL As Range
Dim MMDD As String
 
    Set wb3 = ThisWorkbook
    Set Ws = Workbooks(MMDD & ".xlsx").Worksheets(1)
     
    With wb3.Worksheets(1)
        If .AutoFilterMode Then
            For Cx = 1 To .UsedRange.Columns.Count
                If .AutoFilter.Filters(Cx).On Then
                    If Cx = 16 Then
                        For Each myCELL In .AutoFilter.Range.Columns(Cx).SpecialCells(xlCellTypeVisible)
                            .Cells(myCELL.Row, "M").Value = _
                                Application.VLookup(.Cells(myCELL.Row, "C"), Ws.Columns("C:K"), 5, False)
                            .Cells(myCELL.Row, "N").Value = _
                                Application.VLookup(.Cells(myCELL.Row, "C"), Ws.Columns("C:K"), 9, False)
                        Next
                    End If
                End If
            Next
        End If
    End With
 
End Sub
 
※P列の何らかの条件で検索していたという想定です。
※その結果の可視セル(行)のみをVLOOKUP検索しています。エラー判定無。

投稿日時: 18/04/09 16:08:41
投稿者: coin

WinArrow さん
もこな2 さん
 
色々とありがとうございました。
 
コードを理解するのに、大変時間がかかりました。
失礼致しました。
 
WinArrowさんのコードだと、3行目からデータ部のため、IF文で
If (myCELL.Row = "2") Then
Else
 
という形にしてから、VLOOKUP関数をする事にしました。
 
アドバイスありがとうございます。
 
クローズさせて頂きます。