VBA Help - Find, Cross Reference, Copy/Paste

[MrGrey]

I'm trying to extract key information from a range; below is an example of a sample data set I'm working with (unique IDs can exceed 100, unique Types can exceed 10, Value is variable). The source data is random with each sampling but always arranged by Value, Type, ID. I need to extract the Values associated to Type 2 & 3 (always 2&3) for each ID and then copy those Values to the Destination cells according to ID and Type.

So the macro needs to look at the source data and find Type 2&3 in column 2 then take the Value associated with it in column 1 then cross reference the ID# in column 3 and copy those two Values then past them into the destination cells for the Type 2&3 Values that are associated with each ID#. For users with no Type 2&3 Values blank cells are fine.

You can assume source columns are A, B C and destination columns are E, F, G . I can manipulate these values to make it put the data where I need it.

I already have a method for finding the unique IDs and creating the "destination". But this multiple variable reference is beyond my current skill set. I've seriously been hurting my brain for a couple weeks on this one.

Thanks for anyone who can point me in the right direction.

Source		Destination
Value	Type 1	ID 1			Type 2	Type 3
Value	Type 2	ID 1		ID 1	Value	Value
Value	Type 3	ID 1		ID 2
Value	Type 4	ID 1		ID 3		Value
Value	Type 1	ID 2		ID 4	Value
Value	Type 5	ID 3
Value	Type 3	ID 3
Value	Type 2	ID 4
Value	Type 6	ID 4

<tbody>
</tbody>

 

[MrGrey]

This is possible with VBA right?

 

[NeonRedSharpie]

Sure is!

Sub moveData()

    For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 1
        For y = 2 To Cells(Rows.Count, 4).End(xlUp).Row Step 1
        
            If Cells(x, 3) = Cells(y, 4) Then
                Select Case Cells(x, 2)
                    Case "Type 2"
                        Cells(y, 5) = Cells(x, 1)
                    Case "Type 3"
                        Cells(y, 6) = Cells(x, 1)
                    Case Else
                End Select
            End If
        Next y
    Next x

End Sub

This assumes some of the "Destination" is already built. Allow me to make it a bit more fluid.

Sub moveData()

    Columns(4).Value = Columns(3).Value


    Range(Cells(1, 4), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4)) _
        .RemoveDuplicates Columns:=1, Header:=xlNo
    Cells(1, 4).Insert Shift:=xlDown
    Cells(1, 5) = "Type 2"
    Cells(1, 6) = "Type 3"


    For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 1
        For y = 2 To Cells(Rows.Count, 4).End(xlUp).Row Step 1
        
            If Cells(x, 3) = Cells(y, 4) Then
                Select Case Cells(x, 2)
                    Case Cells(1, 5)
                        Cells(y, 5) = Cells(x, 1)
                    Case Cells(1, 6)
                        Cells(y, 6) = Cells(x, 1)
                    Case Else
                End Select
            End If
        Next y
    Next x
End Sub

I like the first one better...but this one has a bit more flexibility.

 

[MrGrey]

This is great thank you! I'll give it a try and see what I can make it do. I'll report backonce I've got a chance to try it out.

I was up past 5am so I'm having a hard time following the logic by playing it out in my head lol.

 

[MrGrey]

Neon, this is a pretty piece of code! So simple and effective and chews through 200 or so lines of data in a flash! I've never used Case before but now that I've wrapped my head around it I'll be using it more. Thank you!

On the second version you wrote the "remove duplicates" portion is creating a double entry for the first ID once I edited it. I've has this problem before with remove duplicates but I can't seem to figure out why.

I don't need this portion of the code so it's not a big deal. It's more for future reference so I know how to fix it.

This is what I did to it. I'm sure I messed something up.

Columns(5).Value = Columns(3).Value


    Range(Cells(2, 5), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5)) _
        .RemoveDuplicates Columns:=1, Header:=xlNo
    Cells(1, 5).Insert Shift:=xlDown