趣味プログラミングblog

---

Option Explicit

Sub Show_AutoFilterForm()
'https://excel-ubara.com/excelvba3/EXCELFORM002.html
AutoFilterForm.Show vbModeless '・・・ モードレス表示 シート操作可能

End Sub

Sub ▼選択オートフィルタ()
Dim fText1 As String: fText1 = Selection(1).Text
Call オートフィルタ共通モジュール(fText1)
End Sub
Sub ▼選択以外でオートフィルタ()
Dim fText1 As String: fText1 = "<>" & Selection(1).Text
Call オートフィルタ共通モジュール(fText1)
End Sub
Sub ▼検索オートフィルタ()
Dim fText1 As String: fText1 = "*" & Selection(1).Text & "*"
Call オートフィルタ共通モジュール(fText1)
End Sub
Sub ▼クリップボードオートフィルタ()
Dim fText1 As String: fText1 = "*" & GetCB & "*"
Call オートフィルタ共通モジュール(fText1)
End Sub
Sub ▼空白と0以外でオートフィルタ()
Dim fText1 As String: fText1 = "<>"
Dim fText2 As String: fText2 = "<>0"
Call オートフィルタ共通モジュール(fText1, fText2)
End Sub
Function GetCB() As String
'クリップボードから文字列を取得
'https://www.ka-net.org/blog/?p=7537
With CreateObject("Forms.TextBox.1")
.MultiLine = True
If .CanPaste = True Then .Paste
GetCB = .Text
End With
End Function
Sub オートフィルタ共通モジュール(fText1 As String, Optional fText2 As String = "")
If ActiveSheet.AutoFilter Is Nothing Then '<>""ではなく、Nothing
' MsgBox "オートフィルタを設定してください。"
' Exit Sub
If MsgBox("選択セルでオートフィルタを実行します", vbOKCancel) = vbOK Then
Selection.AutoFilter
Else
Exit Sub
End If
End If

Dim myRange As Range: Set myRange = ActiveSheet.AutoFilter.Range


Dim Flag_nodata As Boolean
If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then
Flag_nodata = True
Else
Flag_nodata = False
End If

Dim rc As Long
If Selection.Column > myRange(myRange.Count).Column Then ' 列が範囲より右なら
If Flag_nodata = True Then Exit Sub
rc = MsgBox("オートフィルタ外のため範囲を拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")
If rc <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除
Set myRange = myRange.Resize(, Selection.Column - myRange.Column + 1) 'フィルタ列を選択範囲まで右側に拡張
myRange.AutoFilter
ElseIf Selection.Column < myRange.Column Then
If Flag_nodata = True Then Exit Sub
rc = MsgBox("オートフィルタ外のため範囲拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")
If rc <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除
Set myRange = Cells(myRange.Row, Selection.Column).Resize(myRange.Rows.Count, myRange.Columns.Count + myRange.Column - Selection.Column) 'フィルタ列を選択範囲まで左側に拡張
myRange.AutoFilter
End If

Dim fColNo As Long: fColNo = Selection.Column - myRange.Column + 1 'フィルタ範囲の何番目の列か
'https://www.moug.net/tech/exvba/0030004.html
If ActiveSheet.AutoFilter.Filters(fColNo).On Then '選択中の列が絞り込まれているなら列フィルタ解除
myRange.AutoFilter field:=fColNo
Else
'絞り込まれてないなら
If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then
'MsgBox "列にデータがありません。終了します。"
Exit Sub
Else
'列にデータがあるのでフィルタする
If fText2 = "" Then
myRange.AutoFilter field:=fColNo, Criteria1:=fText1
Else
myRange.AutoFilter field:=fColNo, Criteria1:=fText1, Criteria2:=fText2, Operator:=xlAnd
End If
End If
End If
End Sub
Option Explicit

Private Sub CommandButton1_Click() 'キャンセル
Unload Me
End Sub

Private Sub CommandButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case vbKeyM 'match
Call オートフィルタ事前解除モジュール
Call オートフィルタ共通モジュール(Selection.Value)
Case vbKeyU 'unmatch
Call オートフィルタ事前解除モジュール
Call オートフィルタ共通モジュール("<>" & Selection.Value)
Case vbKeyI 'include
Call オートフィルタ事前解除モジュール
Call オートフィルタ共通モジュール("*" & Selection.Value & "*")
Case vbKeyE 'exclude
Call オートフィルタ事前解除モジュール
Call オートフィルタ共通モジュール("<>*" & Selection.Value & "*")
End Select

End Sub

Private Sub CommandButton2_Click() 'フィルタ適用
Dim CRtext As String

'ラジオボタンチェック
If selectionFlag.Value = True Then
CRtext = Selection.Value
ElseIf ClipBordFlag.Value = True Then
CRtext = GetCB
ElseIf InputFlag.Value = True Then
CRtext = fText.Value
Else
Exit Sub 'そんなのないけどね
End If

If LikeFlag.Value = True Then CRtext = "*" & CRtext & "*"

If NotFlag.Value = True Then CRtext = "<>" & CRtext

Call オートフィルタ事前解除モジュール
Call オートフィルタ共通モジュール(CRtext)
End Sub

Private Sub fText_activate()
OptionButton3 = True
End Sub

Private Sub CommandButton4_Click()
Dim rc As Long
rc = MsgBox("フィルタを全解除します", vbOKCancel)
If rc = vbOK Then
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If
Else
Exit Sub
End If
End Sub

Private Sub CommandButton5_Click()
Call オートフィルタ事前解除モジュール
End Sub



Private Sub fText_Enter()　’テキストボックスをクリックしたらラジオボタンをON
InputFlag = True
End Sub
'
'Private Sub UserForm_Initialize()
'fText.Value = Selection(1).Value
'
'End Sub

Private Sub オートフィルタ事前解除モジュール()
If ActiveSheet.AutoFilter Is Nothing Then '<>""ではなく、Nothing
Selection.AutoFilter
End If

Dim myRange As Range: Set myRange = ActiveSheet.AutoFilter.Range

Dim Flag_nodata As Boolean
If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then
Flag_nodata = True
Else
Flag_nodata = False
End If

Dim rc As Long
If Selection.Column > myRange(myRange.Count).Column Then ' 列が範囲より右なら
If Flag_nodata = True Then Exit Sub
myRange.AutoFilter '一旦オートフィルタを解除
Set myRange = myRange.Resize(, Selection.Column - myRange.Column + 1) 'フィルタ列を選択範囲まで右側に拡張
myRange.AutoFilter
ElseIf Selection.Column < myRange.Column Then
If Flag_nodata = True Then Exit Sub
myRange.AutoFilter '一旦オートフィルタを解除
Set myRange = Cells(myRange.Row, Selection.Column).Resize(myRange.Rows.Count, myRange.Columns.Count + myRange.Column - Selection.Column) 'フィルタ列を選択範囲まで左側に拡張
myRange.AutoFilter
End If

Dim fColNo As Long: fColNo = Selection.Column - myRange.Column + 1 'フィルタ範囲の何番目の列か
'https://www.moug.net/tech/exvba/0030004.html
If ActiveSheet.AutoFilter.Filters(fColNo).On Then '選択中の列が絞り込まれているなら列フィルタ解除
myRange.AutoFilter field:=fColNo
End If
End Sub