Hi,
I’m sorry for the trouble but I realy need your help again if possible?
I have this vb code its working but does not give the complete result, so far gave me 616 correct rows out 1225,
Is there any way you could add or insert loop to this code so it run until “D1:S1225”cells filled with correct result.
The code is to find solution for this tread;
http://www.mrexcel.com/forum/showthread.php?t=634577
Thank you and very much appreciate for any help in advance,
I’m sorry for the trouble but I realy need your help again if possible?
I have this vb code its working but does not give the complete result, so far gave me 616 correct rows out 1225,
Is there any way you could add or insert loop to this code so it run until “D1:S1225”cells filled with correct result.
Code:
Sub sezuh 51,3()
Dim r As Long
For r = 0 To 50000
If r = 1225 Then
Exit For
End If
Next r
Range(Selection, Selection.End(xlDown)).Select
Calculate
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B19600" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:B19600")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("b1:c1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B1225") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("b1:c1225")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim x, y(), i&, j&, k, s, t$, u&, bu As Boolean
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value
With New Dictionary
.CompareMode = 1
For i = 1 To UBound(x): .Item(x(i, 1)) = 1: Next i
x = Range("C1", Cells(Rows.Count, 3).End(xlUp)).Value
ReDim y(1 To UBound(x), 1 To 16)
For i = 1 To UBound(x)
t = x(i, 1)
For Each k In .Keys
s = Split(k)
For j = 0 To UBound(s)
If InStr(t, s(j)) Then bu = True: Exit For
Next j
If bu = False Then
u = u + 1: y(i, u) = k: t = t & " " & k
.Remove k
End If
bu = False
Next k
u = 0
Next i
[u2].Resize(.Count).Value = WorksheetFunction.Transpose(.Keys)
End With
[d1:s1225].Value = y()
Columns("s:s").Select
Selection.AutoFilter
ActiveSheet.Range("$s$1:$s$1225").AutoFilter Field:=1, Criteria1:="<>"
End SubThe code is to find solution for this tread;
http://www.mrexcel.com/forum/showthread.php?t=634577
Thank you and very much appreciate for any help in advance,
