Macro to look up date in column range, insert row and paste data

Question

What I want to do is to have a macro that will:

1. Detect, on page ("Original") the value of a cell ($E8, a date)
2. Go to another page ("Transfer"), (page name varies, but the appropriate page name comes up in "Original" $Z$1.)
3. Look down the A column of "Transfer", which lists every Monday (dates range starts at A20, text above).
4. Find the Monday before that $E8 date (so for $E8 = Sat 17th, it would find Mon 12th)
5. Insert a row BENEATH that Monday row (so before the row that says Mon 19th)
6. Erase that row (so the row goes Mon-12, blank, Mon-19
7. Cut/Copy from ("Original $E8") the range A8:H8
8. Go to the "Transfer" page
9. Insert that A8:H8 selection into the row created at 5.
10. Loop back and do the same thing for $E9 until all the info has been put into "Transfer".

The cells I've given are the right cells, the dates I've just made up (they vary for each account anyway).

Eric has very kindly provided me with a code that I have modified, which is as follows:

 Public Sub do_stuff()
 Dim date_to_look_for As String
 Dim row As Integer

 date_to_look_for = Range("'Original'!K8").Value
                    '^L: This is the cell that you are reading from. Ensure it is the MONDAY formula
 row = 20
 '^L: This is where the Transfer date values start

 Do Until row = Range("'Transfer'!A1").End(xlDown).row + 1  'create our loop.
 'Notice that the .end function will find the end of the data in a column

If Range("'Transfer'!A" & row).Value = date_to_look_for Then
        '^L: Look for Original (X) Value specified above (make sure it's Monday).

    Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
          '^L: Once

    Range("'Transfer'!A" & row + 1 & ":H" & row + 1).Value = Range("'Original'!A8:H8").Value

         '^L:This is WHERE it will paste                           '^L: This is what will copy
    Exit Sub 'no sense in running loop more if already found
End If
 row = row + 1
 Loop

 'If code gets here then the date was never found! so tack to end of list
 Dim endrow As Integer
 endrow = Range("'Transfer'!A1").End(xlDown).row

 Range("'Transfer'!A" & endrow & ":H" & endrow).Value = 
 Range("'Original'!A8:H8").Value
 '^L: What is this?

 End Sub

(The L: messages are my notes as I worked out what each section did - please feel free to correct me if I've misunderstood. The other green 'notes are Eric's and I'm not sure I understand those bits. I don't really need to though, as long as it works, but if you feel like educating me on coding please feel free :D)

My problem is now how to make it loop so it works its way down the original values (in this case the K column, so it goes to K9, K10, etc, and does the same thing? Also, can it CUT instead of COPY, and remove from Original sheet once transferred?

Thanks to everyone who assisted, you guys are great!

Answer 1

This should do what you are looking for. I commented the code so you can read exactly what's happening. Note that this code using Range type variable, which means that the variables rTransfer and rOriginal are referencing actual cells in the worksheet.

Hope this helps! Good luck!

Sub TransferMyData()
'Declare the variables to be used in the code
Dim wsTransfer As Worksheet, wsOriginal As Worksheet
Dim rTransfer As Range, rOriginal As Range, rCopyRange As Range
Dim dMonday As Variant
Dim iRow As Integer

'Set the worksheet variable, this makes is easier than constantly referencing each sheet in the code all the time
Set wsTransfer = ThisWorkbook.Worksheets("Transfer")
Set wsOriginal = ThisWorkbook.Worksheets("Original")

'Set rOriginal to reference range E8, the first cell we are checking for a date to transfer
Set rOriginal = wsOriginal.Range("E8")

'Run this loop over and over until the cell referenced in rOriginal is blank.
'At the bottom of the loop we shift rOriginal down by one
Do While rOriginal <> ""
    'Find the Monday of the week for rOriginal
    dMonday = rOriginal - Weekday(rOriginal, 3)

    'Format dMonay to match the Transfer worksheet - Commented out
    'dMonday = Format(dMonday, "dd-mm-yy")

    'Set the cell of rTransfer using the Find function (Search range A:A in wsTransfer for the monday we figured out above)
    Set rTransfer = wsTransfer.Range("A:A").Find(dMonday)

    'Error check. If rTransfer returns nothing then no match was found
    If rTransfer Is Nothing Then
        MsgBox ("Can't find the Monday for ") & rOriginal & ". Searching for Value " & dMonday
        Exit Sub
    End If

    'Check if there was already some data transfered in for that week (rTransfer.Offset(1,4) references the 'E' column of the row below).
    'If there is a value there, shift down by one and check again
    Do Until rTransfer.Offset(1, 4) = ""
        Set rTransfer = rTransfer.Offset(1, 0)
    Loop

    'Insert a blank row below rTransfer using the offset function
    rTransfer.Offset(1, 0).EntireRow.Insert

    'Set iRow to be the row number of rOriginal to be used below
    iRow = rOriginal.Row

    'Set the range rCopyRange to be the range A:H of the row for iRow (See https://www.mrexcel.com/forum/excel-questions/48711-range-r1c1-format-visual-basic-applications.html for explanation)
    Set rCopyRange = wsOriginal.Range(Cells(iRow, 1).Address, Cells(iRow, 8).Address)

    'Copy the range rCopyRange into the blank row we added
    rCopyRange.Copy rTransfer.Offset(1, 0)

    'Offset our rOriginal cell down by one and restart the loop
    Set rOriginal = rOriginal.Offset(1, 0)

    'Clear out the copied range. Can replace with rCopyRange.Delete if you want to delete the cells and have everything shift up
    rCopyRange.Clear

    'Simple error check, if for some reasone you're stuck in an endless loop this will break out
    If rOriginal.Row > 999 Then
        MsgBox "Error! Stuck in Loop!"
        Exit Sub
    End If
Loop

End Sub

Answer 2

So here is an example that I believe captures what you are trying to do in a general sense. I set up two tabs on my workbook labeled Transfer and Original as you have. I set up my Original Tab to look like the following:

The data in A, B, C, D doesn't really matter. I have Column F and G to determine which date is the "last Monday". This of course can be done in one cell but I broke it apart so you can understand better. So in this example, my F2 cell has =WEEKDAY(A2)-2 as the WEEKDAY function returns the day of the week as a number. I have G2 set as =A2-F2 to actually show the "last Monday date".

I have my Transfer sheet looking like this:

So from here we have to have the macro look up which row is the last monday date from the Transfer tab. We also must make sure it exists. In my example if it doesn't exist I will just tack it to the bottom...

Here is what I wrote for my example with a lot of comments:

Public Sub do_stuff()
Dim date_to_look_for As String
Dim row As Integer

date_to_look_for = Range("'Original'!G2").Value
row = 2 'whichever row is your start row for the data on the Transfer tab

Do Until row = Range("'Transfer'!A1").End(xlDown).row + 1  'create our loop.
'Notice that the .end function will find the end of the data in a column

    If Range("'Transfer'!A" & row).Value = date_to_look_for Then
        'row found for Monday! Do our magic here!

        'insert a blank spot at the row found + 1
        Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'now copy data here
        Range("'Transfer'!A" & row + 1 & ":E" & row + 1).Value = Range("'Original'!A2:E2").Value
        Exit Sub 'no sense in running loop more if already found
    End If
row = row + 1
Loop

'If code gets here then the date was never found! so tack to end of list
Dim endrow As Integer
endrow = Range("'Transfer'!A1").End(xlDown).row

Range("'Transfer'!A" & endrow & ":E" & endrow).Value = 
Range("'Original'!A2:E2").Value

End Sub

Notice how I can copy data at one time using the Range().value function and also notice how I can specify a range too.

After running the macro shown above you should see this in the Transfer tab: