[[20221124035323]]　『対象シートのA列で重複の無い項目（行）を別シーメx（多摩）　ページの最後に飛ぶ

『対象シートのA列で重複の無い項目（行）を別シートのA列に抽出したい』（多摩）

対象シートのA列で重複の無い項目（行）を別シートのA列に抽出したい。
方法は関数でもVBAでもどちらでもOKです。

例えば、対象シートのA列が

	C:\aaa\bbb\ccc
	C:\aaa\bbb
	C:\aaa\bbb\rrr
	C:\g
	D:\EEE\FFF\GGG
	D:\EEE\FFF\GGG\HHH

なら
別シートのA列に

	C:\aaa\bbb
	C:\g
	D:\EEE\FFF\GGG

のように抽出する。

判りにくいと思いますが、抽出条件は
「項目を、先頭から見ていって最後のサブフォルダー名のみが違う項目は抽出しない」
です。

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

一応例示のとおりにはなります。
B列に出力します。（A列、B列ともに見出し行があるという想定です）

 Sub test()
     Dim i As Long
     Range("A1").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
         If Not Cells(i, 1) Like Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2) & "*" Then
             Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row, 2) = Cells(i, 1)
         End If
     Next
 End Sub
（フォーキー） 2022/11/24(木) 07:18:10

 念のための確認ですけど。

 C:\aaa\bbb\rrr
 C:\aaa\bbb\ccc
 C:\aaa\bbb
 C:\aaa
 この場合は何が残りますか？

 C:\aaa
 C:\aaa\bbb
 C:\aaa\bbb\ccc
 C:\aaa\bbb\rrr
 この場合はどうですか？ 
 　
（γ） 2022/11/24(木) 10:27:02

Microsoft365なら

=LET(_flt,FILTER(A:A,A:A<>""),UNIQUE(BYROW(_flt,LAMBDA(_a,XLOOKUP(TEXTBEFORE(_a,"\",-1),_flt,_flt,_a)))))
（d-q-t-p） 2022/11/24(木) 10:46:11

フォーキーさん、回答感謝します。

"*"は"\"の間違いでは無いですか？
"*"ではif文で何もヒットしませんでした。
（B列には、何も抽出されていません）

以下のように修正しましたが、残念ながら抽出はされますが希望の処理ではありませんでした。

Sub test()

     Dim i As Long
     Dim lc As Long

     lc = Cells(Rows.Count, 1).End(xlUp).Row

     Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlNo

     For i = 1 To lc
         If Not Cells(i, 1) Like Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2) & "\" Then
             Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row, 2) = Cells(i, 1)
         End If
     Next
 End Sub

γさんへの返事です。

＞念のための確認ですけど。
＞C:\aaa\bbb\rrr
＞C:\aaa\bbb\ccc
＞C:\aaa\bbb
＞C:\aaa
＞この場合は何が残りますか？

以下の２つが残ります。
C:\aaa\bbb
C:\aaa

＞C:\aaa
＞C:\aaa\bbb
＞C:\aaa\bbb\ccc
＞C:\aaa\bbb\rrr
＞この場合はどうですか？

以下の２つが残ります。
C:\aaa
C:\aaa\bbb

d-q-t-pさん、すいません。
Office365では無くOffice2021でした。

書き出し箇所が間違っている可能性がありますが
アドバイスいただいた関数をB１に書き込んでみましたが
＃NAME?　のエラーがでます。

（多摩） 2022/11/24(木) 12:39:03

＞＃NAME?　のエラーがでます。
でしょうね。時間を無駄にしました。

=LET(_flt,FILTER(A:A,A:A<>""),_arry,IFERROR(IF(COUNTIF(A:A,LEFT(_flt,FIND("♪",SUBSTITUTE(_flt,"\","♪",LEN(_flt)-LEN(SUBSTITUTE(_flt,"\",""))))-1)),"",_flt&""),""),FILTER(_arry,_arry<>""))
（d-q-t-p） 2022/11/24(木) 12:58:37

worksheets(1)が対象シート、worksheets(2)が抽出先として
1行目に見出しがあるものとする。

Sub Test()

    Dim DirName() As String, Target As String
    Dim rMax As Long, i As Long, r As Long, e As Long, l As Long
    Dim Flag As Boolean

    With Worksheets(1)
        rMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim DirName(rMax)

        For r = 2 To rMax
            Target = .Cells(r, 1).Value
            e = InStrRev(Target, "\")
            If e > 3 Then
                DirName(r) = Left(Target, e - 1)
            Else
                DirName(r) = Target
            End If
        Next r

        i = 2
        e = 2
        Do
            For r = 2 To rMax
                If DirName(i) = .Cells(r, 1).Value Then
                    With Worksheets(2)
                        For l = 2 To e
                            If DirName(i) = .Cells(l, 1).Value Then
                                Flag = False
                                Exit For
                            Else
                                Flag = True
                            End If
                        Next l
                        If Flag Then
                            .Cells(e, 1).Value = DirName(i)
                            e = e + 1
                        End If
                    End With
                End If
            Next r
            i = i + 1
        Loop Until i > rMax
    End With

End Sub

（ngk） 2022/11/24(木) 13:33:53

 >"*"は"\"の間違いでは無いですか？
 >"*"ではif文で何もヒットしませんでした。
 >（B列には、何も抽出されていません）

 *はワイルドカードです。
C:\aaa*ならC:\aaaで始まる文字を含みます。

こちらのテストではA列に例示の項目（１行目は見出し行）、B列に見出し行のみという環境で例示の通りにはなります。

ただ、その後のγさんへの返事を見ると、cドライブ直下のフォルダーは対象外のようなので、作成したコードでは対応できません。
（フォーキー） 2022/11/24(木) 13:34:36

フォーキーさん、お時間を割いていただきありがとうございました。

d-q-t-pさん、12:58:37の関数式を試してみました。
　検証のためのサンプルが不足しているかも知れませんが
　いくつかのパターンで検証して過不足なく上手く抽出されました。

　素晴らしいアドバイスありがとうございます。
　

ngkさん、VBAでの回答ありがとうございます。

VBAを検証してみました。
上手く抽出される行とされない行が有るようです。

どんな場合が抽出されないのかを目を皿のようにして見ていますが
パターンの違いが有るはずですが原因が見つけられていません。

添付した画像は一つのサンプルでの結果です。
（これで何かヒントらしきパターンの違いは見つかるでしょうか？）

色分け行は、
　緑色がngkさんのマクロで抽出された行です。
　水色及び黄色は、抽出されるべき行ですが検出されていない行です。
（赤色は、不必要なので抽出されてはいけない行です。）

（多摩） 2022/11/24(木) 16:42:58

区切り位置で分けて、ソートするなりした方が簡単では？
（楽） 2022/11/24(木) 16:52:02

＞区切り位置で分けて、ソートするなりした方が簡単では？

アドバイスされている内容が良く理解できていないと思うのですが
「\」で全て分けてからソートすると言うことですか

そうだとしてその後自動でどうやって必要でない所を判断するのですか？

補足位ただければ理解が深まると思います。
（多摩） 2022/11/24(木) 17:21:02

＞補足位ただければ理解が深まると思います

すいません。
変換ミスがありました。

補足いただければ理解が深まると思います　に訂正します。
（多摩） 2022/11/24(木) 17:23:19

 >「\」で全て分けてからソートすると言うことですか

 そういう事。

 >そうだとしてその後自動でどうやって必要でない所を判断するのですか？

 ソート後に自分で見て判断するんですよ、
 固まってるから、判別しやすいだろうという事。

 全て自動とか、他人任せだと無理か。
（楽） 2022/11/24(木) 17:46:23

d-q-t-pさんの回答で解決したんですよね？
一応コードで作ってみました。
正直、条件がいまいちわからないのですが、

 c\aaa
 c\aaa\bbb\ccc
 c\aaa\bbb\ccc\ddd
だと
 c\aaa
 c\aaa\bbb\ccc
のように、一定の階層以降（という言い方が正しいかはわからないんですが）重複しているものを削除したいということですか？

下のコードだと、\で区切った時、要素が4以下のものはそのまま反映
4以上だと、抽出した直前の文字と比較して、重複しているか確認します。
（B1セルには見出し行を入れてください）
文字によって重複許容数が変わる場合は対応できないです。

どの階層まで許容するかはコメントの部分のコードを変更してください。
多分外している可能性が高いですし、もっとスマートなやり方があると思います。

 Sub test2()
     Dim i As Long, s
     Range("A1").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
         s = Split(Cells(i, 1), "\")
         If UBound(s) < 4 Then   '\で区切った時、重複していい最大数が4以外の場合は変更
             Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row, 2) = Cells(i, 1)
         Else
             If Not Cells(i, 1) Like Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2) & "*" Then
                 Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row, 2) = Cells(i, 1)
             End If
         End If
     Next
 End Sub
（フォーキー） 2022/11/24(木) 18:14:23

きちんと対象を並べてLike演算子で比較するだけ

  Sub fname()
    'A列に対象の文字列が並んでいるとする
    'B列に対象の重複を削除した降順の文字列が出来る
    'C列に結果表示

    Columns("A:A").Copy
    Columns("B:B").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp)).RemoveDuplicates Columns:=1
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add key:=Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp)) _
          , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Dim clct As Collection
    Set clct = New Collection
    For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
      clct.Add Trim(Cells(i, "B").Value)
    Next

    For i = 1 To clct.Count
      For j = clct.Count To i + 1 Step -1
        If clct.Item(j) Like Replace(clct.Item(i), "#", "[#]") & "\*" Then
          Call clct.Remove(j)
        End If
      Next
    Next

    For i = 1 To clct.Count
      Cells(i, "C").Value = clct.Item(i)
    Next

  End Sub
（スズキ） 2022/11/24(木) 19:17:19

皆さん、たくさんの回答ありがとうございます。

私の最初の前提となる質問の条件提示の考えが甘く、
その後、マクロ等で複数のサンプルで試してみましたがどうも思ったような結果が出ませんでした。
（一度は、d-q-t-pさんの関数で処理できたと思ったのですが思ったような結果が出ないケースも多々ありました。）

そこで、解決には至りませんでしたが別の方法を模索したいと思います。
（具体的には、楽さんが提示した「\」で全て分けてからソートすると言うことを想定しています。
別の質問にしたいと思います。）

協力いただきありがとうございました。
（多摩） 2022/11/25(金) 16:42:07

コメント返信：

[ 一覧(最新更新順) ]

[[20221124035323]] 『対象シートのA列で重複の無い項目（行）を別シーメx（多摩） ページの最後に飛ぶ

[[20221124035323]]　『対象シートのA列で重複の無い項目（行）を別シーメx（多摩）　ページの最後に飛ぶ