View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
JAgger1 JAgger1 is offline
external usenet poster
 
Posts: 42
Default Copy Matching Numbers To New Cell's

Excellent! That works perfect. Thanks again Garry


On Jan 23, 8:41*pm, GS wrote:
Try...

Sub CheckForDupes2()
* Dim v1, v2, vCalcMode 'as variant
* Dim s1 As String, bEventsEnabled As Boolean
* Dim i&, j&, lMatches&, r& 'as long
* With Application
* vCalcMode = .Calculation: bEventsEnabled = .EnableEvents
* * .Calculation = xlCalculationManual: .EnableEvents = False
* * .ScreenUpdating = False
* End With 'Application
* For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 1
* * v1 = Range("$A$" & r & ":$J$" & r)
* * v2 = Range("$A$" & r & ":$J$" & r).Offset(1)
* * s1 = "": lMatches = 0 '//initialize variables for each pass
* * For i = 1 To Range("$A:$J").Columns.Count
* * * For j = 1 To Range("$A:$J").Columns.Count
* * * * If v2(1, i) = v1(1, j) _
* * * * * And Not InStr(1, s1, v2(1, i)) 0 Then _
* * * * * s1 = s1 & "," & v2(1, i): lMatches = lMatches + 1: Exit For
* * * Next 'j
* * Next 'i
* * With Range("$L$" & r).Offset(1).Resize(1, lMatches)
* * * .Value = Split(Mid$(s1, 2), ","): .NumberFormat = "General"
* * End With
* Next 'r
* With Application
* * .Calculation = vCalcMode: .EnableEvents = bEventsEnabled
* * .ScreenUpdating = True
* End With 'Application
End Sub 'CheckForDupes2

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc