[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『対象シートの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 >
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
=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
>この場合は何が残りますか?
以下の2つが残ります。
C:\aaa\bbb
C:\aaa
>C:\aaa
>C:\aaa\bbb
>C:\aaa\bbb\ccc
>C:\aaa\bbb\rrr
>この場合はどうですか?
以下の2つが残ります。
C:\aaa
C:\aaa\bbb
d-q-t-pさん、すいません。
Office365では無くOffice2021でした。
書き出し箇所が間違っている可能性がありますが
アドバイスいただいた関数をB1に書き込んでみましたが
#NAME? のエラーがでます。
(多摩) 2022/11/24(木) 12:39:03
=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
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列に例示の項目(1行目は見出し行)、B列に見出し行のみという環境で例示の通りにはなります。
ただ、その後のγさんへの返事を見ると、cドライブ直下のフォルダーは対象外のようなので、作成したコードでは対応できません。
(フォーキー) 2022/11/24(木) 13:34:36
d-q-t-pさん、12:58:37の関数式を試してみました。
検証のためのサンプルが不足しているかも知れませんが
いくつかのパターンで検証して過不足なく上手く抽出されました。
素晴らしいアドバイスありがとうございます。
ngkさん、VBAでの回答ありがとうございます。
VBAを検証してみました。
上手く抽出される行とされない行が有るようです。
どんな場合が抽出されないのかを目を皿のようにして見ていますが
パターンの違いが有るはずですが原因が見つけられていません。
添付した画像は一つのサンプルでの結果です。
(これで何かヒントらしきパターンの違いは見つかるでしょうか?)
色分け行は、
緑色がngkさんのマクロで抽出された行です。
水色及び黄色は、抽出されるべき行ですが検出されていない行です。
(赤色は、不必要なので抽出されてはいけない行です。)
アドバイスされている内容が良く理解できていないと思うのですが
「\」で全て分けてからソートすると言うことですか
そうだとしてその後自動でどうやって必要でない所を判断するのですか?
補足位ただければ理解が深まると思います。
(多摩) 2022/11/24(木) 17:21:02
すいません。
変換ミスがありました。
補足いただければ理解が深まると思います に訂正します。
(多摩) 2022/11/24(木) 17:23:19
>「\」で全て分けてからソートすると言うことですか
そういう事。
>そうだとしてその後自動でどうやって必要でない所を判断するのですか?
ソート後に自分で見て判断するんですよ、 固まってるから、判別しやすいだろうという事。
全て自動とか、他人任せだと無理か。 (楽) 2022/11/24(木) 17:46:23
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
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.