try the following macro. As I saw no date in your sheet, I based the macro on today's date to determine the week to transfer data to.
Public Sub Transfer_Data()
Dim End_Of_Week_Date As Date, EOW_Found As Range
'Determine the end of this week (next Friday)
'If we are on weekend, then Friday of next week
If Weekday(Now(), vbMonday) <= 5 Then
End_Of_Week_Date = Now() + 5 - Weekday(Now(), vbMonday)
Else
End_Of_Week_Date = Now() + 12 - Weekday(Now(), vbMonday)
End If
End_Of_Week_Date = DateSerial(Year(End_Of_Week_Date), Month(End_Of_Week_Date), Day(End_Of_Week_Date))
'
'Locating the column to transfer the data
Set EOW_Found = Sheets("Sheet1").Rows(3).Find(End_Of_Week_Date)
'If we found the right column then transfer data
If Not EOW_Found Is Nothing Then
EOW_Found.Offset(9, 0) = Range("A13")
EOW_Found.Offset(9 + 14, 0) = Range("A27")
EOW_Found.Offset(9 + 28, 0) = Range("A41")
EOW_Found.Offset(9 + 42, 0) = Range("A55")
EOW_Found.Offset(9 + 56, 0) = Range("A69")
EOW_Found.Offset(9 + 70, 0) = Range("A83")
End If
End Sub
Bookmarks