|
こんな感じでどうかな ?
データのあるシートを開いて実行します。アクティブシートの次のシートのA,B列に
抽出した重複値を表示します。
Sub MyMatch()
Dim LR1 As Long, LR2 As Long
Dim Nm As String
Dim x As Variant, y As Variant
Application.ScreenUpdating = False
With ActiveSheet
If .Index = Worksheets.Count Then Exit Sub
Nm = .Name & "!"
LR1 = .Range("A65536").End(xlUp).Row
LR2 = .Range("B65536").End(xlUp).Row
With .Next
.Cells.ClearContents
.Range("A1:A" & LR1).Formula = _
"=IF(ISERR(MATCH(" & Nm & "$A1," & Nm & "$B:$B,0)),""Z"",ROW()&"".""&$A1)"
.Range("C1:C" & LR2).Formula = _
"=IF(ISERR(MATCH(" & Nm & "$B1," & Nm & "$A:$A,0)),""Z"",ROW()&"",""&$B1)"
.Range("A:C").Copy
.Range("A1").PasteSpecial xlPasteValues
.Range("A1:A" & LR1).Sort Key1:=.Columns(1), _
Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
.Range("C1:C" & LR2).Sort Key1:=.Columns(3), _
Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
x = Application.Match("Z", .Range("A:A"), 0)
If Not IsError(x) Then
.Range("A" & x & ":A65536").ClearContents
End If
y = Application.Match("Z", .Range("C:C"), 0)
If Not IsError(y) Then
.Range("C" & y & ":C65536").ClearContents
End If
.Range("A1:A" & LR1).TextToColumns DataType:=xlDelimited, _
Comma:=True
.Range("C1:C" & LR2).TextToColumns DataType:=xlDelimited, _
Comma:=True
.Columns(3).Delete xlShiftToLeft
.Columns(1).Delete xlShiftToLeft
.Activate
End With
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
|
|