Identifying Column Number from Reference

Hi, I'm not very good at this and am having real trouble. Been messing around with some Find functions & googling for help. My problem is very simple I believe (but this is not my forte!)

I have attached an example sheet to illustrate what I mean.

CODE HELP.xlsx

Basically all I want to do is use cell B2 as a reference, to lookup the matching column to that ref in the array D:R. Then copy A2:A20 and paste in the second row of the appropriate column.

:d

TIA for any help!

Sub Copy_to_Matched_Column()
    Dim Found As Range
    Set Found = Range("D1:R1").Find(What:=Range("B1").Value, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False)
    If Not Found Is Nothing Then
        Range("A2:A20").Copy Destination:=Found.Offset(1)
    Else
        MsgBox "No column match found. ", , "No Column Match"
    End If
End Sub

Thank you so much! I see this works great in my example, and in my actual working sheet too. The only problem is that I just need it to paste the values. I've been trying to figure out how I could add in:

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

But to no avail. Thanks for your help!

Replace this...
Range("A2:A20").Copy Destination:=Found.Offset(1)

With this...
Found.Offset(1).Resize(19).Value = Range("A2:A20").Value

That's amazing! Thank you so much! The only (very small) issue I have is that the range I'm copying has 14997 rows (A3:A15000). So I think I did the correct thing by setting the Resize(14997)? But obviously this takes a bit of time to process.

About 500 per time produce data. I have looked into using 'Special Cells' but am not entirely sure if they are appropriate, or how to implement them. Is this or any other way worth investigating in order to speed up the macro? (I already turn off screen updating and calculation before running it)

Originally Posted by cloudwalking

That's amazing! Thank you so much! The only (very small) issue I have is that the range I'm copying has 14997 rows (A3:A15000). So I think I did the correct thing by setting the Resize(14997)? But obviously this takes a bit of time to process.

About 500 per time produce data. I have looked into using 'Special Cells' but am not entirely sure if they are appropriate, or how to implement them. Is this or any other way worth investigating in order to speed up the macro? (I already turn off screen updating and calculation before running it)

You're welcome.

A3:A15000 = 14998 rows

This should take practically no time (sub-second) to copy the values.
Found.Offset(1).Resize(14998).Value = Range("A3:A15000").Value


I didn't understand what this means;"About 500 per time produce data. "

Just means that each time I'm only copying over around 500 filled cells (within A3:A15000). The rest are blank (actually they have LOOKUP formula, but are returning blanks). I have also devised a method with a check box to turn Calculation off on this sheet alone. There's no conditional formatting wither. But it still seems to take a while to paste the data. :-(

The copy value method is not the bottleneck. It's hard to say what is without seeing your actual workbook. If you copy the 15000 rows in your example workbook, you can see how fast it is.

The code below suspends Calculations, Events, and Screenupdating while copying. This may improve the speed.

Sub Copy_to_Matched_Column()
    
    Dim Found As Range, lCalcState As Long
    
    Set Found = Range("D1:R1").Find(What:=Range("B1").Value, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False)
    If Not Found Is Nothing Then
        With Application
            lCalcState = .Calculation
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
                Found.Offset(1).Resize(14998).Value = Range("A3:A15000").Value
            .Calculation = lCalcState
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    Else
        MsgBox "No column match found. ", , "No Column Match"
    End If
    
End Sub