Loop for each date in the worksheet

[Rainmanne]

I've got a worksheet with all the data in 1 column in the following sequence: date, name, data, comment, number, blank repeating for a month. I need to move the data cell and the number cell to the right to the date. So I am trying to write a simple loop:

For each date in the worksheet,
offset 2 cells down, copy
offset 1 column to the right, paste
offset 4 cells down, copy
offset 2 columns to the right, paste
Next date
Until the last date on the worksheet

So I am thinking to write something like this:

Sub data_move ()
Dim i as Integer
Dim d as Range
For each i
   Find date and make it d
   d.Offset(2,0).Copy
   d.Offset(0,1).Paste
   d.Offset(4,0).Copy
   d.Offset(0,2).Paste
Next i

Not sure if the copy/paste part will work but before that I have stuck with finding each date. Could anyone please help?

 

[6StringJazzer]

After you move the data and number to the same row as the date, do you want to:

1. Delete those rows
2. Blank out the data and number but keep the rows
3. Keep those rows as-is

The code you showed takes the third option but I want to make sure before I provide code.

 

[Rainmanne]

Yes, the 3d option. I will then just sort it by date.

 

[6StringJazzer]

I would try this but I have not created a file from scratch to test it. Generally direct assignments will be faster and cleaner than copy & paste:

Sub data_move ()

Dim i as Integer
Dim d as Range

i = 1 ' first row containing a date. Change if you have header rows.

Do Until Cells(i, "A") = ""    '  no more dates

   Cells(i, "B") = Cells(i + 2, "A")
   Cells(i, "C") = Cells(i + 4, "A")

   i = i + 6

Loop

However, if you need to also preserve formats then here is a copy/paste solution. You can do a copy & paste all on one line of code if you don't need any Paste Special options.

Sub data_move ()

Dim i as Integer
Dim d as Range

i = 1 ' first row containing a date. Change if you have header rows.

Do Until Cells(i, "A") = ""    '  no more dates

   Cells(i + 2, "A").Copy Cells(i, "B")
   Cells(i + 4, "A").Copy Cells(i, "C")

   i = i + 6

Loop

 

[Rainmanne]

Thanks a lot for that!

I would try this but I have not created a file from scratch to test it. Generally direct assignments will be faster and cleaner than copy & paste:

Sub data_move ()

Dim i as Integer
Dim d as Range

i = 1 ' first row containing a date. Change if you have header rows.

Do Until Cells(i, "A") = ""    '  no more dates

   Cells(i, "B") = Cells(i + 2, "A")
   Cells(i, "C") = Cells(i + 4, "A")

   i = i + 6

Loop

However, if you need to also preserve formats then here is a copy/paste solution. You can do a copy & paste all on one line of code if you don't need any Paste Special options.

Sub data_move ()

Dim i as Integer
Dim d as Range

i = 1 ' first row containing a date. Change if you have header rows.

Do Until Cells(i, "A") = ""    '  no more dates

   Cells(i + 2, "A").Copy Cells(i, "B")
   Cells(i + 4, "A").Copy Cells(i, "C")

   i = i + 6

Loop