Index / Match one column multiple matching values - transposed to a new row

[Drrellik]

Hello all,

I have searched and searched, however I am not using the right key words or just over looking what is probably already in the forums somewhere so thank you in advance for your time.

I have been working on a sheet tracking lottery numbers and mostly for fun and a learning project.

I have created 5 columns B-F from row 3 - 500 for all the numbers B3:F500 range

In Column B using the forums help and conditional formatting I have highlighted the values the proceed the last drawing value.

meaning if the last lottery number in position 1 was 11 then in cell B3 would be the number 11 and then any cell in that column B3:B500 that had a matching value of 11.. the cell directly above it would be highlighted.


https://www.mrexcel.com/forum/excel-questions/1049966-conditional-formatting-offset.html


Now I would like to run through each column and extract or copy the highlighted values and move them to same sheet cell U74 - AP74 this is a row range of about 22 cells and should accommodate all the duplicates.


I tried index/match in several ways with a -1 and not actually worry about VBA and the interior.cell color without success and I have been searching for that elusive example in VBA as well.

So if there is a simple formula I don't know about would someone just give me a push in the right direction.... ((no to hard please)

Thank you

~DR

 

[Marcelo Branco]

Not sure i fully understand what you want - see if this example with a small data sample (B3:C18) helps

B​

C​

D​

E​

F​

G​

H​

I​

J​

K​

L​

M​

1​

2​

3​

11​

4​

2​

6​

9​

2​

7​

6​

11​

22​

4​

2​

5​

5​

11​

6​

6​

4​

4​

7​

5​

45​

8​

6​

10​

9​

11​

11​

10​

8​

4​

11​

2​

7​

12​

9​

8​

13​

11​

2​

14​

2​

22​

15​

11​

4​

16​

12​

3​

17​

7​

11​

18​

11​

11​

19​

<tbody>
</tbody>

Run this macro

Sub aTest()
    Dim dic As Object, i As Long, j As Long
    Dim vData As Variant, lKey As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("B3:C18").Value '<--adjust the range to suit
    
    For i = LBound(vData, 2) To UBound(vData, 2)
        For j = LBound(vData, 1) To UBound(vData, 1) - 1
            If vData(j + 1, i) = vData(1, i) Then
                lKey = lKey + 1
                dic(lKey) = vData(j, i)
            End If
        Next j
    Next i
    Range("E3").Resize(, dic.Count) = dic.items
End Sub

Results in E3:L3 (gray area)

M.

 

[Drrellik]

That is Perfect.

I am going to try and modify it myself and add to it.

The B column numbers will need to go to Range("U74")....

The C Column Numbers will need to go to Range("U76")...

D = U78

E= U80... and so on.

But yes you understood what I was after and this is great.

Thank you

 

[Marcelo Branco]

You are welcome. Thanks for the feedback.

Try to adapt the code to your real case, but tell us if you face some problems.

M.

 

[Drrellik]

Sub aTest()
  
 ' Column B 1st Mega Millions Number
 
    Dim dic As Object, i As Long, j As Long
    Dim vData As Variant, lKey As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("B3:b500").Value '<--adjust the range to suit
    
    For i = LBound(vData, 2) To UBound(vData, 2)
        For j = LBound(vData, 1) To UBound(vData, 1) - 1
            If vData(j + 1, i) = vData(1, i) Then
                lKey = lKey + 1
                dic(lKey) = vData(j, i)
            End If
        Next j
    Next i
    Range("u74").Resize(, dic.Count) = dic.items
    
 ' Column C 2nd Number
 
        Dim secnd As Object, i2 As Long, j2 As Long
    Dim vData2 As Variant, lKey2 As Long
    
    Set secnd = CreateObject("Scripting.Dictionary")
    vData2 = Range("c3:c500").Value '<--adjust the range to suit
    
    For i2 = LBound(vData2, 2) To UBound(vData2, 2)
        For j2 = LBound(vData2, 1) To UBound(vData2, 1) - 1
            If vData2(j2 + 1, i2) = vData2(1, i2) Then
                lKey = lKey + 1
                secnd(lKey) = vData2(j2, i2)
            End If
        Next j2
    Next i2
    Range("u76").Resize(, secnd.Count) = secnd.items
    
 ' Column D  3rd Number
 
        Dim thrd As Object, i3 As Long, j3 As Long
    Dim vData3 As Variant, lKey3 As Long
    
    Set thrd = CreateObject("Scripting.Dictionary")
    vData3 = Range("d3:d500").Value '<--adjust the range to suit
    
    For i3 = LBound(vData3, 2) To UBound(vData3, 2)
        For j3 = LBound(vData3, 1) To UBound(vData3, 1) - 1
            If vData3(j3 + 1, i3) = vData3(1, i3) Then
                lKey3 = lKey3 + 1
                thrd(lKey3) = vData3(j3, i3)
            End If
        Next j3
    Next i3
    Range("u78").Resize(, thrd.Count) = thrd.items
    
 ' Column E  4th Number
 
        Dim frth As Object, i4 As Long, j4 As Long
    Dim vData4 As Variant, lKey4 As Long
    
    Set frth = CreateObject("Scripting.Dictionary")
    vData4 = Range("e3:e500").Value '<--adjust the range to suit
    
    For i4 = LBound(vData4, 2) To UBound(vData4, 2)
        For j4 = LBound(vData4, 1) To UBound(vData4, 1) - 1
            If vData4(j4 + 1, i4) = vData4(1, i4) Then
                lKey4 = lKey4 + 1
                frth(lKey4) = vData4(j4, i4)
            End If
        Next j4
    Next i4
    Range("u80").Resize(, frth.Count) = frth.items
    
 ' Column F  5th Number
 
        Dim fith As Object, i5 As Long, j5 As Long
    Dim vData5 As Variant, lKey5 As Long
    
    Set fith = CreateObject("Scripting.Dictionary")
    vData5 = Range("f3:f500").Value '<--adjust the range to suit
    
    For i5 = LBound(vData5, 2) To UBound(vData5, 2)
        For j5 = LBound(vData5, 1) To UBound(vData5, 1) - 1
            If vData5(j5 + 1, i5) = vData5(1, i5) Then
                lKey5 = lKey5 + 1
                fith(lKey5) = vData5(j5, i5)
            End If
        Next j5
    Next i5
    Range("u82").Resize(, fith.Count) = fith.items
    
   ' Column G  Gold Ball / PB
   
        Dim sixth As Object, i6 As Long, j6 As Long
    Dim vData6 As Variant, lKey6 As Long
    
    Set sixth = CreateObject("Scripting.Dictionary")
    vData6 = Range("g3:g500").Value '<--adjust the range to suit
    
    For i6 = LBound(vData6, 2) To UBound(vData6, 2)
        For j6 = LBound(vData6, 1) To UBound(vData6, 1) - 1
            If vData6(j6 + 1, i6) = vData6(1, i6) Then
                lKey6 = lKey6 + 1
                sixth(lKey6) = vData6(j6, i6)
            End If
        Next j6
    Next i6
    Range("u84").Resize(, sixth.Count) = sixth.items
End Sub

I cheated, took your code and modified it to use the right range, and repeated the code with tweaks to make it work for me, I am sure there is a shorter version out there but this is exactly what I needed a push in the right direction.

Thank you again

 

[markmzz]

That is Perfect.

I am going to try and modify it myself and add to it.

The B column numbers will need to go to Range("U74")....

The C Column Numbers will need to go to Range("U76")...

D = U78

E= U80... and so on.

But yes you understood what I was after and this is great.

Thank you

Hi!

Here is my suggeston with formula: Try the Array Formula (use Ctrl+Shift+Enter to enter the formula) below in U74 and copy to the right

=IFERROR(SMALL(IF(INDEX($B$4:$F$500,,CEILING(ROWS(U$74:U74),2)/2)=INDEX($B$3:$F$3,CEILING(ROWS(U$74:U74),2)/2),
INDEX($B$3:$F$499,,CEILING(ROWS(U$74:U74),2)/2)),COLUMNS($U74:U74)),"")

After that, select the range U74:AP75 and copy down.

Markmzz

 

[Marcelo Branco]

I cheated, took your code and modified it to use the right range, and repeated the code with tweaks to make it work for me, I am sure there is a shorter version out there but this is exactly what I needed a push in the right direction.

Try this new version

Sub NewVersion()
    Dim dic As Object, i As Long, j As Long
    Dim vData As Variant, lKey As Long, lLin As Long
    
    vData = Range("B3:G500").Value
    lLin = 72
    For i = LBound(vData, 2) To UBound(vData, 2)
        Set dic = CreateObject("Scripting.Dictionary")
        lKey = 0
        For j = LBound(vData, 1) To UBound(vData, 1) - 1
            If vData(j + 1, i) = vData(1, i) Then
                lKey = lKey + 1
                dic(lKey) = vData(j, i)
            End If
        Next j
        lLin = lLin + 2
        If dic.Count Then Range("U" & lLin).Resize(, dic.Count) = dic.items
    Next i
End Sub

M.

 

[Drrellik]

Try this new version

Sub NewVersion()
    Dim dic As Object, i As Long, j As Long
    Dim vData As Variant, lKey As Long, lLin As Long
    
    vData = Range("B3:G500").Value
    lLin = 72
    For i = LBound(vData, 2) To UBound(vData, 2)
        Set dic = CreateObject("Scripting.Dictionary")
        lKey = 0
        For j = LBound(vData, 1) To UBound(vData, 1) - 1
            If vData(j + 1, i) = vData(1, i) Then......

M.

That is easier.

Thanks ~DR

 

[Marcelo Branco]

You are welcome. Glad to help

M.

 

[markmzz]

That is easier.

Thanks ~DR

Hi Drrellik!

Did you try my suggestion (with array formula) of the Post #6?

Markmzz​