Excelのマクロでの部分的な重複データの抽出方法

質問

お世話になります。
Excelのマクロで部分的な重複データの抽出をしたいと考えています。
データの内容は下記のような感じです。
名称 No.
AAA 111-11
BBB 111-12
CCC 111-21
DDD 111-23
EEE 121-13
FFF 201-31
GGG 201-32
HHH 53-1
JJJ 53-2
KKK 91-1
桁数（文字数）が2通りあり、前述のものは-(ハイフン)のすぐ後の文字（基本的に数字ですが、アルファベットの場合もあります）までの内容で重複データを削除したいです。後述の短いものは-(ハイフン)の直前までの内容で重複データを削除したいです。最後の文字は無視して重複を省きたいという事です。
最終的なデータの希望内容は、
名称 No.
AAA 111-11
CCC 111-21
EEE 121-13
FFF 201-31
HHH 53-1
KKK 91-1
です。
現状、関数のLENなどを利用してある程度手を加えていますが、できれば全てマクロでできないかと欲を出してます・・・・。お願いします。

回答No.4

n-jun · ベストアンサー

ANo.3です。

＞これの場合、最初の"-"で見てしまって、正しくデータが取れないようです。この場合は、どのようにすればよいのでしょうか？

Sub try2()
Dim Dic As Object
Dim i As Long, st As String
Dim v, w

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
v = .Range(.Range("A2"), .Cells(Rows.Count, 2).End(xlUp)).Value
Worksheets("Sheet2").Range("A1:B1").Value = .Range("A1:B1").Value
End With

For i = 1 To UBound(v, 1)
w = Split(v(i, 2), "-")

Select Case UBound(w)
Case 1
st = w(0) & "-" & IIf(Len(w(1)) > 1, Left(w(1), 1), "")
Case 2
st = w(0) & "-" & w(1) & "-" & IIf(Len(w(2)) > 1, Left(w(2), 1), "")
Case Else
End Select

If Not Dic.Exists(st) Then
Dic(st) = Array(v(i, 1), v(i, 2))
End If

Next

With Worksheets("Sheet2")
.Range("B:B").NumberFormatLocal = "@"
.Range("A2").Resize(Dic.Count, 2).Value = _
Application.Transpose(Application.Transpose(Dic.Items))
End With

Set Dic = Nothing
Erase v
End Sub

と言う事でしょうか？

お礼

ありがとうございます。
この方法で解決できました。
参考になります。

回答No.5

Wendy02

こんばんは。

数式さえ入れられれば、マクロでするほどの内容ではないような気がします。
ここでは、E列を利用しています。

数式を入れてダブリを出し、それをソートして、削除します。
標準モジュールに入れてお使いください。

Sub Test1()
　　Dim lRow As Long
　　Dim i As Long
　　Dim c As Variant

　　lRow = Range("B65536").End(xlUp).Row - 1 '2行目から
　　'不要のハイフンの削除
　　For Each c In Range("B2").Resize(lRow)
　　　　Do Until Replace(c.Value, "--", "") = c.Value
　　　　　　c.Value = Replace(c.Value, "--", "-")
　　　　Loop
　　Next c
　　'関数の代入
　　Range("E2").Resize(lRow).Formula = _
　　"=COUNTIF(R2C2:RC2,MID(RC[-3],1,FIND(""-"",RC[-3])+(LEN(RC[-3])>5)*1)&""*"")"
　　'並べ替え
　　Range("A2").Resize(lRow, 5).Sort _
　　Key1:=Range("E2"), _
　　Order1:=xlAscending, _
　　Header:=xlNo, _
　　OrderCustom:=1, _
　　MatchCase:=False, _
　　Orientation:=xlTopToBottom
　　'1以上の数字を探す
　　For i = 2 To lRow
　　　　If Cells(i, 5) > 1 Then
　　　　　　Exit For
　　　　End If
　　Next i
　　'1以上があれば、削除
　　If i < lRow Then
　　　　Range(Cells(i, 1), Cells(lRow + 1, 5)).ClearContents
　　End If
　　'代入式の削除
　　Range("E2").Resize(lRow).ClearContents
End Sub

お礼

Wendy02さん、ありがとうございます。
こういう方法もあるのですね。
参考にさせていただきます。

回答No.3

n-jun

ANo.2です。

念のため、
st = w(0) & IIf(Len(w(1)) > 1, Left(w(1), 1), "")
を
st = w(0) & "-" & IIf(Len(w(1)) > 1, Left(w(1), 1), "")
として下さい。

お礼

n-junさん、ありがとうございます。
教えていただいた内容で解決できました。
ちなみに、他のデータを確認していたところ、
名称 No.
AAA A1-111-11
BBB A1-111-12
CCC A2-111-21
DDD A2-111-23
EEE A5-121-13
FFF B1-201-31
GGG B3-201-32
HHH H1-53-1
JJJ H1-53-2
という感じで、-(ハイフン)を2つ利用しているものがありました。
これの場合、最初の"-"で見てしまって、正しくデータが取れないようです。この場合は、どのようにすればよいのでしょうか？
すみません、マクロの勉強を始めたばかりで困っています。

回答No.2

n-jun

例題の通りの結果を出すのであれば、

Sub try()
Dim Dic As Object
Dim i As Long, st As String
Dim v, w

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
v = .Range(.Range("A2"), .Cells(Rows.Count, 2).End(xlUp)).Value
Worksheets("Sheet2").Range("A1:B1").Value = .Range("A1:B1").Value
End With

For i = 1 To UBound(v, 1)
w = Split(v(i, 2), "-")
st = w(0) & IIf(Len(w(1)) > 1, Left(w(1), 1), "")

If Not Dic.Exists(st) Then
Dic(st) = Array(v(i, 1), v(i, 2))
End If

Next

With Worksheets("Sheet2")
.Range("B:B").NumberFormatLocal = "@"
.Range("A2").Resize(Dic.Count, 2).Value = _
Application.Transpose(Application.Transpose(Dic.Items))
End With

Set Dic = Nothing
Erase v
End Sub

で出来ましたけど。
ご参考程度に。

回答No.1

n-jun

重複しているとの判断は
＞111-11　・・・
の部分なのでしょうか？

＞基本的に数字ですが、アルファベットの場合もあります
明確に提示すべきかと。

お礼

すみません、説明不足でした。
＞ 重複しているとの判断は
＞ ＞111-11　・・・
＞ の部分なのでしょうか？

はい。例で出した "No." の列です。

＞ ＞基本的に数字ですが、アルファベットの場合もあります
＞ 明確に提示すべきかと。
名称 No.
AAA 111-11
BBB 111-A2
CCC 111-21
DDD 111-23
のような感じになります。
右から2文字目の部分が1～Zまでの版数として利用しているためです。
（最後の文字は無視してもらってかまいません）