Copy Values based on a Match Q
 

I have the code below that Copy-Paste Values-Transposes values in
Column D8:D33 (on sheet Input) to the row that matches the value in D6
(on sheet Input) held in Column A starting in Row 7 (on sheet YTD).

This works great except I have 35 columns in total to copy based on a
match ColA YTD. I can repeat this code 35 times, but is there a way to
incorporate a loop with the code below that will have the same effect?


Sub PostInputValues()
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim rng As Range, rng1 As Range
Dim cell As Range, dt As Date
Set sh = Worksheets("Input")
dt = sh.Range("D6").Value
With Worksheets("YTD")
Set rng = .Range(.Cells(7, 1), .Cells(7, 1).End(xlDown))
End With
For Each cell In rng
If cell.Value2 = CLng(dt) Then
Set rng1 = cell
Exit For
End If
Next
If rng1 Is Nothing Then
MsgBox Format(dt, "dd-mm-yy") & " was not found"
Exit Sub
End If
sh.Range("D8:D33").Copy
rng1.Offset(0, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
Worksheets("YTD").Select
Range("C7").Select

Worksheets("Input").Select
Range("B5").Select
Application.CutCopyMode = False

End Sub