[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『重複するデータの優先順位の下位を削除』(だんなさん)
上記の表から下記の表ように、
同じアルファベットが存在する場合は、
優先順位の最も高い(数値の小さい)部分だけ残し、
その他を削除する方法を探しています。
また、削除したセルは詰めずに、そのままの位置関係を希望します。
位置関係が崩れなければ、別のシートや列に移動させても構いません。
関数でもVBAでもどちらでも構いません。
どうぞよろしくお願いします。
例
優先順位 5 2 4 1 3 あ A A B い A A B B C う A A A B ︙
優先順位 5 2 4 1 3 あ A B ←優先順位2のAは残し、4のAは削除 い A B C ←5のA,4のBは削除 う A B ←2のA,4のAは削除 ︙
< 使用 Excel:Excel2007、使用 OS:Windows10 >
おはようございます。
方法は、色々あるでしょうけど、、、一例です。
Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim v As Variant Dim i As Long Dim j As Long Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet1") MyA = .Range("A1").CurrentRegion.Value End With For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(i, 1) & MyA(i, j)) Then ReDim v(1) v(0) = MyA(1, j) v(1) = j MyDic(MyA(i, 1) & MyA(i, j)) = v Else v = MyDic(MyA(i, 1) & MyA(i, j)) If Val(v(0)) > Val(MyA(1, j)) Then MyA(i, Val(v(1))) = Empty v(0) = MyA(1, j) v(1) = j MyDic(MyA(i, 1) & MyA(i, j)) = v Else MyA(i, j) = Empty End If End If Next Next With Sheets("Sheet2") .Cells.Clear .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA End With Set MyDic = Nothing Erase MyA, v End Sub ※今回の例ではたまたま上手くいきましたが、同じものが見つかった時に 優先順位の低いデータに変えておかないと上手くいかない時がありますね?多分、、、 で、ちょっと訂正です。 (SoulMan) 2019/03/22(金) 06:40
おはようございます。。。^^ Sheet2にだんなさん さんの結果図と同じ内容が出力されました。v(^^)///vvv 何時もながら配列操作がお見事ですね。わたしも、朝ごはん食べながら考えていましたが ひらめかなかったです。。。^^;;;。。。でわでわ。。。m(_ _)m (隠居じーさん) 2019/03/22(金) 07:24
おはようございます いつもありがとうございます😊 いつものワンパターンですよ汗 進歩がない_| ̄|○ また、よろしくお願いします (SoulMan) 2019/03/22(金) 07:57
i2 =(countif($b$1:$f$1,"<"&b$1,$b2:$f2,b2),"",b2&"")
必要数下とm列までフィルコピー
(sy) 2019/03/22(金) 12:48
(sy) 2019/03/22(金) 17:41
SoulMan さん、ありがとうございます!
ばっちり結果が出ました。こちらをベースに他にもいろいろと応用も出来そうです。
sy さん、ありがとうございます!
頭にIFを付けたところ、こちらもばっちり結果が出ました。
I2 =IF(COUNTIFS($B$1:$F$1,"<"&B$1,$B2:$F2,B2),"",B2&"")
皆さん、ありがとうございます!
(だんなさん) 2019/03/22(金) 18:54
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.