comparing two lists

[vochris]

hello

I have a list of names, some of which occur several times, with values attributed to the names in the adjacent column. I want a list in which the names occur once and the all the values belonging to the name appear in the row the name is in. I have code which almost does it, but not quite.

My data looks like this example:

fred 10
dave 1
jill 4
fred 11
marc 74

I want:

dave 1,
fred 10,11
jill 4,
marc 74,

so I start with a list

dave
fred
jill
marc

and then run my code.


My code is:

Option Explicit
Sub Compare()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, LR As Long
Set ws1 = Sheets("Deutsch")
Set ws2 = Sheets("Deutsch2")

For j = 2 To 182
i = 2

Do
If ws1.Cells(i, 5) = ws2.Cells(j, 5) Then
ws2.Cells(j, 6).Value = ws1.Cells(i, 6).Value
End If
i = i + 1
If i = 314 Then
Exit Do
End If
Loop Until ws2.Cells(j, 6) <> ""

Do
If ws1.Cells(i, 5) = ws2.Cells(j, 5) Then
ws2.Cells(j, 7).Value = ws1.Cells(i, 6).Value
End If
i = i + 1
If i = 314 Then
Exit Do
End If
Loop Until ws2.Cells(j, 7) <> ""

If i < 314 Then
Do
If ws1.Cells(i, 5) = ws2.Cells(j, 5) Then
ws2.Cells(j, 8).Value = ws1.Cells(i, 6).Value
End If
i = i + 1
If i = 314 Then
Exit Do
End If
Loop Until ws2.Cells(j, 8) <> ""
End If

Next j


End Sub



It works fine for a while, then gives me an 'error 1004 object or application error' at always the same point, when it gets to row 144 in the destination list.

The editor tells me I should debug the line 'If ws1.Cells(i, 5) = ws2.Cells(j, 5)' in the second 'Do'-block in the code.

Does anybody have any idea what is wrong in that line? I would much appreciate any feedback.

Thanks, Chris

 

[MickG]

Hi, This will not sort your particular problem , but it will give you some code to work with.
I Assumed you Data is in columns "A & B".
Results will be in column "E" on.

Sub DupCol()
Dim rng As Range, Dn As Range, n As Long, Ray
Dim Last As Long, Q, col As Integer
Set rng = Range(Range("A1"), Range("a" & Rows.Count).End(xlUp))
ReDim Ray(1 To rng.Count, 1 To Columns.Count)

With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In rng
         If Not .Exists(Dn.Value) Then
            n = n + 1
            Ray(n, 1) = Dn.Value: Ray(n, 2) = Dn.Offset(, 1)
           .Add Dn.Value, Array(n, 2)
        Else
           Q = .Item(Dn.Value)
           Q(1) = Q(1) + 1
           Ray(Q(0), Q(1)) = Dn.Offset(, 1)
           col = Application.Max(Q(1), col)
          .Item(Dn.Value) = Q
        End If
    Next

End With

Range("E1").Resize(n, col).Value = Ray
    
End Sub

Regards Mick

 

[pboltonchina]

Hi MickG
I'm very interetsed in your reply, it does something that is perfect for a project I'm doing at the moment. I've tried it and it's great.
What would need to be changed on the code to look at column B and give results from column A, like backwards so if I have a list of names in column A, and a list of items in column B I want 2 differnt macros, one I have now that looks at A and gives results from B, and one that looks at B, and gives results from A, if that makes sense. Could the results be put to the right of the first results rather than overwriting them?

Thanks very much

Regards
Paul

 

[MickG]

Hi Paul, This is the Names in column "B" Numbers in column "A" code.
Results start Column "C".
Change the Range Address in last line to suit where you want the Results.

Sub DupColLeft()
Dim rng As Range, Dn As Range, n As Long, Ray
Dim Last As Long, Q, col As Integer
Set rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
ReDim Ray(1 To rng.Count, 1 To Columns.Count)

With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In rng
         If Not .Exists(Dn.Value) Then
            n = n + 1
            Ray(n, 1) = Dn.Value: Ray(n, 2) = Dn.Offset(, -1)
           .Add Dn.Value, Array(n, 2)
        Else
           Q = .Item(Dn.Value)
           Q(1) = Q(1) + 1
           Ray(Q(0), Q(1)) = Dn.Offset(, -1)
           col = Application.Max(Q(1), col)
          .Item(Dn.Value) = Q
        End If
    Next

End With

Range("C1").Resize(n, col).Value = Ray

Regards Mick

 

[vochris]

Hi Mick

Thanks for your answer. I'll have a look at that code and see if it solves my problem.

Regards, Chris

 

[pboltonchina]

Hi MickG,

That is fantastic, perfect, you've made an old man very happy.

Live long and prosper.

Kindest Regards
Paul

 

[vochris]

Hi Mick

It works a dream. Thanks very much.

Regards, Chris

 

[vochris]

Hi Mick

I'm trying to adapt your code slightly, but I don't quite get what is happening inside the 'Else'-clause. As far as I understand, it deals with the multiple cases. The first line sets Q to a number, equivalent to the number of times the Name (Dn.Value) we are currently looking at is already in the array 'Ray'. The line defining the variable 'col' is also relatively unproblematic.

But what about the rest? Is Q also an array? And what is Q(1)?

Would appreciate any leads.

Regards, Chris

 

[MickG]

Hi, It is quite difficult to explain, It is best to "Google" (Scrip Dictionary).
I found the best way to understand is to step through the code with lots of Msgboxes, or use the "Immediate window" to find values.
I've tried to adds some notes to the code. Hope they help.

Sub DupCol()
Dim rng As Range, Dn As Range, n As Long, Ray
Dim Last As Long, Q, col As Integer
Set rng = Range(Range("A1"), Range("a" & Rows.Count).End(xlUp))
ReDim Ray(1 To rng.Count, 1 To Columns.Count)
'The Scripting dictionary Finds unique Values, say in a list
'the are Called "Keys", it also find secondary items relating to the "Keys"
'these are called "Items" , could be an offset value.
'In this particular case the code uses an array as the "Item"
'"n" is a counting number for the Number of Uniques and "2" is a column Count for the Results.
' "2" is the starting number because, the Array "Ray" has already use "1 & 2"
' and as this number is increase  after the !Else "Statemnet" the next number (Column) will be 3.
'As the uniques are found their values and there offset values are stored in the Array "Ray"
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In rng
         If Not .Exists(Dn.Value) Then
            n = n + 1
            Ray(n, 1) = Dn.Value: Ray(n, 2) = Dn.Offset(, 1)
           .Add Dn.Value, Array(n, 2)
        Else

'Q is an Array representing the "item" of the Dn.value.
'As we want to increase the column for the results, the second item Q(1)(First item = item "0")
'is increased by "1"in the line Q(1) = Q(1) + 1
'NB:- Any items that appear in the "Else" statement, are duplicates, and each have an unique identity "n"
'relating back to the Unique items Already stores, and also denotes the row in the array "Ray" that they are stored in.
'NB:- When an Item appears in the "Else" Statement, it original value already held in the Scrip Dictionary
'Can be found by relating to its ".item(Dn.value)" as below.
'This way each "key" duplicate can have its own values of Q(0) and Q(1). relating back to the original Value in the "Scrip Dic"
'After the Q(1) value are increased, the original Array "Q" is reset with these new values in the statement .item(Dn.value)= Q
'This process repeats itself until the entire list is Covered, and the results Displayed as the array "Ray" 
          Q = .Item(Dn.Value)
           Q(1) = Q(1) + 1
           Ray(Q(0), Q(1)) = Dn.Offset(, 1)
           col = Application.Max(Q(1), col)
          .Item(Dn.Value) = Q
        End If
    Next

End With

Range("C1").Resize(n, col).Value = Ray
    
End Sub

Regards Mick

 

[vochris]

Hi

Thanks very much for taking the time to put in those notes. Its much clearer now and with a little more work I think I'll get the hang of it.

Regards, Chris