Extract Matching Cell Values in Two Columns and Paste in New Columns

[branston]

Hi

New here and seem to have hit a brick wall so back to the board.

I have tried amending some previous code to give me a different output. Seemed simple enough but I am not getting the desired output and I'm also not sure it's the most efficient method.

Basically I have two columns and all I am trying to do is copy any matching/duplicate names in both columns to a new column J. Column I is simply numbered 1,2,3, etc and is dynamically generated.

The number of candidates in both columns can of course change and is not fixed.

I've attached my file and would appreciate any help. I can do it in Excel but would like a Excel VBA script to do it.

Many thanks in advance.

[branston]

Anyone?

[p45cal]

try

Sub MatchCandidates()
Application.ScreenUpdating = False
Dim LastRow As Long, GR1 As Long, aName As Range, bName As Range
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
GR1 = Range("B:B").Find("GROUP 1").Row
With Range("I4:J" & LastRow)
  .Borders.LineStyle = xlNone
  .ClearContents
End With
'Cells(Rows.Count, "B").End(xlUp).Select
Set BList = Range(Cells(Rows.Count, "B").End(xlUp), "B" & GR1 + 1)
'BList.Select
Set FList = Range(Cells(Rows.Count, "F").End(xlUp), "F" & GR1 + 1)
'FList.Select
    
Set Destn = Range("J4")    'where the firsdt result will go.
For Each cll In FList.Cells
  If Not IsError(Application.Match(cll.Value, BList, 0)) Then
    Destn.Value = cll.Value
    Set Destn = Destn.Offset(1)
  End If
Next cll
    
    
With Range("I4")
  If .Offset(0, 1) <> "" Then    'check that there is some data to deal with
    .Value = 1
    On Error Resume Next    ' suppress the error message, no series to fill
    .AutoFill Destination:=Range("I4").Resize(Range("J" & Rows.Count).End(xlUp).Row - 3), Type:=xlFillSeries
    On Error GoTo 0    'reinstate error notification
    .Resize(Range("J" & Rows.Count).End(xlUp).Row - 3, 3).Borders.LineStyle = xlContinuous
  End If
End With
Application.ScreenUpdating = True
End Sub

From your code it looks like you thought that GR1 would be at the bottom of the list but it remained the row on which GROUP 1 was found in column B.

[大灰狼1976]

Hi branston!
I made a macro with autofilter, which was interesting.
Column I is not processed, sorry.

--Okami

Sub test()
Dim arr, rng As Range
arr = Range("f4:f" & [f65536].End(3).Row)
arr = Application.Transpose(arr)
Application.ScreenUpdating = False
[a4].AutoFilter Field:=2, Criteria1:=arr, Operator:=xlFilterValues
Range("b4:b" & [b65536].End(3).Row).Copy [j4]
[a4].AutoFilter
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

[branston]

Thanks p45cal - that's a great help.

If there was some data at the top of the columns and some more data below both columns, would it be possible to fix the range of the array? Of course this list may change but as long as I can fix the array range then it should not be an issue. I only want the data from the fixed array and not all of the data above and below.

Sorry I should have been clearer in my original post.

I've attached the file again so you know what I mean.

Thanks again

[branston]

Thanks Okami that looks very neat.

I wasn't clear in my original post ... If there was some data at the top of the columns and some more data below both columns, would it be possible to fix the range of the array? Of course this list may change but as long as I can fix the array range then it should not be an issue. I only want the data from the fixed array and not all of the data above and below.

Also there are no numbers dynamically generated on the new list in column I ???? ie. 1,2,3,etc. however many candidates are matching.

Thank again

[大灰狼1976]

Hi branston!
No problem if there are empty rows and columns between the upper and lower data sources.

Sub test()
Dim arrOri, arrRst, d As Object, i&, r&
Set d = CreateObject("scripting.dictionary")
arrOri = [a7].CurrentRegion
ReDim arrRst(1 To UBound(arrOri), 1 To 2)
For i = 3 To UBound(arrOri)
  d(arrOri(i, 2)) = ""
Next i
arrOri = [e7].CurrentRegion
For i = 3 To UBound(arrOri)
  If d.exists(arrOri(i, 2)) Then
    r = r + 1
    arrRst(r, 1) = r
    arrRst(r, 2) = arrOri(i, 2)
    d.Remove arrOri(i, 2)
  End If
Next i
[i9].Resize(r, 2) = arrRst
End Sub

[branston]

Thanks Okami - really appreciate it.

If I try to move my range around the spreadsheet and amend the code slightly for some reason the matching names are not being selected and copied properly. For e.g. if I wanted Group2 candidates matching you can see it is just listing the names in TASKA GROUP2 instead of matching them with TASKB GROUP2 candidates.

What am I doing wrong?

File attached.

[大灰狼1976]

Hi branston!
Currtregion can only get the size of a separate area.
There must be empty rows and columns between data areas.
In your current example, the data areas are linked together,
so it needs to be processed.

Sub test()
Dim arrOri, arrRst, d As Object, i&, r&
Set d = CreateObject("scripting.dictionary")
[i9].CurrentRegion.ClearContents
'arrOri = [N9].CurrentRegion  'for test
arrOri = [N72].CurrentRegion
'arrOri = [N120].CurrentRegion  'for test
ReDim arrRst(1 To UBound(arrOri), 1 To 2)
For i = 3 To UBound(arrOri)
  If arrOri(i, 2) = "" Then Exit For
  d(arrOri(i, 2)) = ""
Next i
For i = 3 To UBound(arrOri)
  If arrOri(i, 6) = "" Then Exit For
  If d.exists(arrOri(i, 6)) Then
    r = r + 1
    arrRst(r, 1) = r
    arrRst(r, 2) = arrOri(i, 6)
    d.Remove arrOri(i, 6)
  End If
Next i
[i9].Resize(r, 2) = arrRst
End Sub

[p45cal]

If lists of names are going to be all over the place, and they're not all headed with the same headers or tasks, then it might be easier each time to ask the user where they are and where he wants the results.
The following will ask the user this and allow him to select them with the mouse:

Sub MatchCandidates()
Dim List1 As Range, List2 As Range, Destn As Range
On Error Resume Next
Set List1 = Application.InputBox("Select the first list of names", "1st List", , , , , , 8)
If List1 Is Nothing Then Exit Sub
Set List2 = Application.InputBox("Select the second list of names", "2nd List", , , , , , 8)
If List2 Is Nothing Then Exit Sub
Set Destn = Application.InputBox("Select where you want the results", "Destination", , , , , , 8)    'where the result will go.
If Destn Is Nothing Then Exit Sub
On Error GoTo 0

Set List1 = List1.Columns(1)
Set List2 = List2.Columns(1)
Set Destn = Destn.Cells(1)

Application.ScreenUpdating = False
Count = 0    'for numbering the results
For Each cll In List2.Cells
  If Not IsError(Application.Match(cll.Value, List1, 0)) Then
    Count = Count + 1
    Destn.Value = Count
    Destn.Offset(, 1).Value = cll.Value
    Set Destn = Destn.Offset(1)
  End If
Next cll
Application.ScreenUpdating = True
End Sub

[branston]

Thanks p45cal .. will give it a shot. Not exactly what I'm after but it may be a better longer term solution for me.

[branston]

Okami - this is great. Thank you for your help. Didn't realise you could do an autofilter like this in a macro - very neat.

Okami - I am trying to add some more data to my final list. This data comes from the '#' and 'Room' columns. Of course this data does not have to match as only the names need to match.

Is it possible to copy this data across also (even though it doesn't match). I've tried amending the code but it doesn't work. Also the Title Headings for each column disappear when the final list is created. I need them to stay intact. If the final table could have a border around it that would be great.

I've attached my list again - could you take a look please?


Thanks again for all your help.

[branston]

If anybody could help I would appreciate it as it's a bit urgent and I can't seem to get my head around it!

BTW The above screenshot should read "A-GRP2" (not "A-GRP1")

[大灰狼1976]

Hi branston!
TASK B - GROUP 1 has some duplicate data, and the corresponding # number and room number is different, How to deal with it.
In addition, will TASK A have the same situation as TASK B?

[branston]

Hi Okami

I have attached a screen shot of how the data should look. Any data that is with a matching name just needs to be copied across regardless of whether it matches the other group or not. Only the names in each group need to match not any additional data.

(The final list needs borders around it to make it clear to read)

Hope this is clear and thanks again.

[大灰狼1976]

Sorry, the picture is not clear. Can you explain it in a workbook?
Everything else is OK. I need to see how duplicate data is processed in the same TASK of the same GROUP.

[branston]

Hi Okami

No problem. I've attached the file again but I have just copied the additional column data ( in columns I,J,K,L,M ) manually from columns (O,R,V,U,W). Obviosuly I would want this doing automatically via the macro.

I am concerned about all of the other data around the table and whether this will affect the final list data once processed?

File attached and thank you.

[branston]

Hi

Would it possible to do this with a range of cells being copied across into the final destination (as opposed to just one column each)?

The dilemma I have is that only columns P and T only are being matched for equivalence, but if I wanted the corresponding cells in columns Q and R (for column P) and cells in columns U,V,W (for column T) also being copied .. how would I do that because I am not bothered if cells in columns Q and R and columns U,V,W match or not?

[大灰狼1976]

Hi branston!
The processing method is very simple. I just don't understand how to deal with the duplicate data.
Please simulate a result of the blue area of the attachment.

[branston]

Hi Okami

Very sorry not sure how that has happened, there should not be duplicate names in column T. Must have been a copying error.

I've removed the duplicates and attached the file again. Is it clear now?