【ノーコード】VBAコードを作成する無料アプリ

AIで自分の価値を高める方法とは🙄

MENU

フィルターとドロップダウンリストを連動(複数列可能)

エクセルVBAマクロを自動作成する無料アプリです。

例として「フィルターとドロップダウンリストを連動」させるVBAマクロを作成します。

事例 

 

アプリへのリンク

アプリへのリンク
 ⇒複数列フィルター(ドロップダウンリスト/部分一致)

 

アプリの画面



作成されたコード

アプリで作成したコードを、VBE画面に貼り付けて実行します。

 

 

ドロップダウンリストを選択するとフィルターが実行されました。


ドロップダウンリストをダブルクリックすると、フィルターが解除されます。

 

ポイント
作成されたコードは標準モジュールではなく、
   対象のシートのシートモジュールに貼り付けます

できました😊

 

VBAコードを見る

  
'【重要】作成したコードは、標準モジュールではなく、対象のシートのシートモジュールに貼り付けます

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("a3:e3")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Target.Select
    Call デモ_1(Target)
    Application.EnableEvents = True
End Sub


Sub デモ_1(Target As Range) '複数列フィルター(部分一致も可能)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim currentColumn As Long
    currentColumn = Target.Column - Range("a3:e3").Cells(1, 1).Column + 1
    With Sheets("Sheet1").Range("a7")
            If isEmpty(Target.Value) Then
                .AutoFilter Field:=currentColumn
            ElseIf IsNumeric(Target.Value) Then
                .AutoFilter Field:=currentColumn, Criteria1:=Target
            ElseIf IsDate(Target.Value) Then
                .AutoFilter Field:=currentColumn, Criteria1:=Format(Target, Sheets("Sheet1").Cells(Range("a7").Row, Range("a7").Column + currentColumn - 1).NumberFormatLocal)
            Else
                .AutoFilter Field:=currentColumn, Criteria1:="*" & Target & "*"
            End If
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("a3:e3")) Is Nothing Then Exit Sub
    Call デモ_2(Target)
    SendKeys "%{DOWN}"
End Sub

Sub デモ_2(Target As Range)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    With Sheets("Sheet1")
        Dim lastRow As Long, currentColumn As Long
        currentColumn = Range("a7").Column + Target.Column - Range("a3:e3").Cells(1, 1).Column
        lastRow = .Cells(Rows.Count, currentColumn).End(xlUp).Row
        Dim dict As Object, myRow As Long
        Set dict = CreateObject("Scripting.Dictionary")
        For myRow = Range("a7").Row To lastRow
            If Not .Cells(myRow, currentColumn).EntireRow.Hidden Then
                If Not dict.Exists(.Cells(myRow, currentColumn).Value) Then
                    dict.Add .Cells(myRow, currentColumn).Value, ""
                End If
            End If
        Next myRow
        Dim list As Variant
        list = dict.keys
        If UBound(list) < 0 Then
            MsgBox "元データの範囲に値がありません"
            Exit Sub
        End If
        With Target.Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:=Join(list, ",")
        End With
        Set dict = Nothing
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("a3:e3")) Is Nothing Then
        Target.ClearContents
        Target.Validation.Delete
        Cancel = True
    End If

End Sub