[[20190408010829]]　『(マクロ)　オートフィルタで条件3+ワイルドカード』（マイン）　ページの最後に飛ぶ

『(マクロ)　オートフィルタで条件3+ワイルドカードで抽出方法』（マイン）

お世話になっております。
検索値が3つ以上ある場合では、配列を使用すれば抽出可能とのことで
以下のようにしてみました。

ただ、問題は、"東○○○"とすれば抽出出来るのですが、「○○○」の部分をワイルドカードにした場合エラーがでます。

皆様なにとぞ、アドバイスをお願いします。

        Dim array1(2) As String
        array1(0) = "東*"
        array1(1) = "西*"
        array1(2) = "南*"

        .Range("A1").AutoFilter Field:=25, Criteria1:=array1, Operator:=xlFilterValues

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

 フィルタオプション（AdvancedFilter）でどうでしょう？
    Sub Macro4()
        Dim dt As Range
        Dim cri As Range
        ActiveSheet.ShowAllData
        Set dt = Range("A1").CurrentRegion
        Set cri = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(2)
        cri(2).Formula = "=OR(LEFT(A2)={""東"",""南"",""西"",""北""})"
        dt.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=cri, Unique:=False
        cri.ClearContents
    End Sub

（稲葉） 2019/04/08(月) 08:59

 エラーメッセージを教えてください
 省略しないで、実行可能で、エラーが再現するコードを載せてください
（でれすけ） 2019/04/08(月) 09:08

でれすけさま

失礼しました、以下が並び替えと抽出のコードです。

エラーと申しましたが

具体的には、格納された値はワイルドカードと認識されずに？、不一致として全てのデータが非表示になってしまいました。

arrayにそれぞれ、ワイルドカードを使用せずに全ての抽出条件を記載すれば正常に抽出されます。

arrayを使用すれば3つ以上の抽出が可能とありましたので、もしかしたらワイルドカードも使えるのでは？と思い書き込みしました。

Sub 集計処理()

    Dim sh1 As Worksheet: Set sh1 = Worksheets("Source")

    With sh1
        If .FilterMode = True Then
            .ShowAllData
        End If
        If .AutoFilterMode = False Then
            .Range("A1:Y1").AutoFilter
        End If

        Dim array1(2) As String
       array1(0) = "東*"
        array1(1) = "西*"
        array1(2) = "南*"
        '昇順で項目ごとひとかたまりにする
        .Range("A1").Sort key1:=.Range("Y1"), order1:=xlAscending, Header:=xlYes
        .Range("A1").AutoFilter Field:=25, Criteria1:=array1, Operator:=xlFilterValues

     End With
End Sub
（マイン） 2019/04/08(月) 09:57

稲葉さま

ありがとうございます。

フィルタオプション（AdvancedFilter）ですね。確かにネットでも多数掲載がありました。

作業Sheetがあるので、そこに抽出条件を記載し参照させる方法も検討したいと思います。
（マイン） 2019/04/08(月) 10:33

 実行時エラーがでるのと、狙ったとおりの動作をしないのでは、意味が違いいます。

 ワイルドカード使うと、配列で指定しても配列要素2つまでしか対応してないようです。
 稲葉さんの提案のように、AutoFilterを使うのがいいと思います。
（でれすけ） 2019/04/08(月) 10:40

でれすけ　さま

ご指摘ありがとうございました。
やはり、フィルタオプションで挑戦してみます。
（マイン） 2019/04/08(月) 10:58

初めてフィルタオプションで組んでみました。

抽出条件をマスタに配置することで幾つもの条件に対応できて有能でした。

以下コード。

Sub 集計処理()

    Dim sh1 As Worksheet: Set sh1 = Worksheets("Source")
    Dim sh2 As Worksheet: Set sh2 = Worksheets("集計")
    Dim sh3 As Worksheet: Set sh3 = Worksheets("マスタ")

    With sh1
        If .FilterMode = True Then
            .ShowAllData
        End If
        If .AutoFilterMode = False Then
            .Range("A1:Y1").AutoFilter
        End If

        '部署
        .Range("A1").Sort key1:=.Range("Y1"), order1:=xlAscending, Header:=xlYes
        .Range("A1:Y" & .Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                         sh3.Range("H1:H" & sh3.Cells(Rows.Count, 8).End(xlUp).Row), Unique:=False
        '雇用
        .Range("A1").Sort key1:=.Range("X1"), order1:=xlAscending, Header:=xlYes
        .Range("A1:Y" & r).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                         sh3.Range("G1:G" & sh3.Cells(Rows.Count, 7).End(xlUp).Row), Unique:=False

        '表示している行番号を取得
        Dim t, e As Long
        t = 2
        While .Rows(t).Hidden    '先頭行
            t = t + 1
        Wend
        e = .Cells(.Rows.Count, "E").End(xlUp).Row    '最終行
        '転記(上下には非表示セルある)
        .Range(.Cells(t, 1), .Cells(e, 3)).Copy
        sh2.Cells(2, 1).PasteSpecial Paste:=xlPasteValues    'A社員番号   B社員名 C年月日
        .Range(.Cells(t, 23), .Cells(e, 23)).Copy
        sh2.Cells(2, 4).PasteSpecial Paste:=xlPasteValues    'W勤務実績
        .Range(.Cells(t, 7), .Cells(e, 7)).Copy
        sh2.Cells(2, 5).PasteSpecial Paste:=xlPasteValues    'G勤務区分
        .Range(.Cells(t, 13), .Cells(e, 14)).Copy
        sh2.Cells(2, 6).PasteSpecial Paste:=xlPasteValues    'M所定内労働 N実働時間
        .Range(.Cells(t, 21), .Cells(e, 21)).Copy
        sh2.Cells(2, 8).PasteSpecial Paste:=xlPasteValues    'Uメモ
        .Range(.Cells(t, 25), .Cells(e, 25)).Copy
        sh2.Cells(2, 9).PasteSpecial Paste:=xlPasteValues    'Y部署
    End With

End Sub
（マイン） 2019/04/08(月) 13:13

すみません、以下修正です。
最終行の取得が間違っていました。

'雇用

        .Range("A1").Sort key1:=.Range("X1"), order1:=xlAscending, Header:=xlYes
        .Range("A1:Y" & .Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                         sh3.Range("G1:G" & sh3.Cells(Rows.Count, 7).End(xlUp).Row), Unique:=False
（マイン） 2019/04/08(月) 13:30

訂正のためいったん削除

（もこな２） 2019/04/09(火) 19:10

遅レスですし、フィルタオプションで処理する方向で固まったようですが、オートフィルタ好きとして、別案を考えてみました。

    Sub 集計処理_乙()
        Dim MyRNG As Range
        Dim array1() As String          '動的配列として宣言
        Dim i As Long

        With Worksheets("Source")
            .AutoFilterMode = False     'オートフィルタ強制解除
            .Range("A1:Y1").AutoFilter  '抽出せずにオートフィルタだけ設定

            '▼ワイルドカードを含まない配列を作成
            For Each MyRNG In Intersect(.AutoFilter.Range.Offset(1), .Range("Y:Y"))
                If MyRNG.Value Like "東*" Or MyRNG.Value Like "西*" Or MyRNG.Value Like "南*" Then
                    ReDim Preserve array1(i)
                    MyArr(i) = MyRNG.Value
                    i = i + 1
                End If
            Next MyRNG

            '昇順で項目ごとひとかたまりにする（もとのまま）
            .Range("A1").Sort key1:=.Range("Y1"), order1:=xlAscending, Header:=xlYes
            .Range("A1").AutoFilter Field:=25, Criteria1:=array1, Operator:=xlFilterValues
         End With
    End Sub

でれすけさんの
＞ワイルドカード使うと、配列で指定しても配列要素2つまでしか対応してないようです。
をヒントにして、ワイルドーカードを【含まない】配列ならOKと考えた場合、こんな感じでも処理できそうです。

ただ、
＞抽出条件をマスタに配置することで幾つもの条件に対応できて有能でした。
とのことですから、オートフィルタでやる場合、そちらの対応も必要になりそうです。

（もこな２） 2019/04/10(水) 05:46

もこな2　さん

すみません見落としていました。
ありがとうございます。私もオートフィルタ好きです！！。

早速確認したいと思います。
（マイン） 2019/04/11(木) 22:28

コメント返信：

[ 一覧(最新更新順) ]

[[20190408010829]] 『(マクロ) オートフィルタで条件3+ワイルドカード』（マイン） ページの最後に飛ぶ

[[20190408010829]]　『(マクロ)　オートフィルタで条件3+ワイルドカード』（マイン）　ページの最後に飛ぶ