エクセル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 SubSub デモ_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 IfEnd Sub