vba to create 2 rows of data from 1 row

Hi,

I am trying to extract certain columns from a row to another row in anothe worksheet, which is working.

so data looks like this.

aaaa bbbb date figure 1 figure 2 mmmmm xxxxx yyyyy

extracted data should look like this

aaaa date figure 1 mmmmm xxxxx
bbbb date figure 2 mmmmm yyyyy

If I only have one original line my code worked perfectly, However, when I have say 4 original rows the 1st line of extracted data comes out ok but the second line does not.
I am using R1C1 formula filling down to extract the data. which is ok if there is only I line cause the formula would be R1C1 for extract 1, and R-1C1 for extract 2. But if I have the additional lines the 2nd extract pulls nothing as it is pointing to the wrong place.

Here is the code I have sofar based around a loop

Sub createintl()


Dim rcounter As Integer
Dim rcountera As Integer

Worksheets("Main").Activate
rcountera = 2
rcounter = 4
'loop through workout sheet until column 5 is blank
Do While Worksheets("Workout").Cells(rcountera, 5) <> ""

On Error Resume Next
'fill out the main sheet with the extracted data from the workout sheet
    ActiveSheet.Cells(rcounter, 1).Formula = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(rcounter, 2).Formula = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(rcounter, 3).Formula = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(rcounter, 6).Formula = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(rcounter, 7).Formula = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(rcounter, 9).Formula = "=Workout!R[-2]C[8]"
    ActiveSheet.Cells(rcounter, 10).Formula = "=""blabla"""
    ActiveSheet.Cells(rcounter, 13).Formula = "=Workout!R[-2]C[8]"
    
rcountera = rcountera + 1
rcounter = rcounter + 1
Loop


End Sub

'this sub starts after the previous has finished by entering data after the last row extracted in the previous sub
Sub createnos()


Dim rcounter As Integer
Dim rcountera As Integer


Worksheets("Main").Activate
rcountera = 2
'go to the final row in the main sheet, this will be the last row extracted by the first sub
finalrow = Cells(65536, 2).End(xlUp).Row + 1
'loop the extract until column 5 is empty on the workout sheet
Do While Worksheets("Workout").Cells(rcountera, 5) <> ""

On Error Resume Next


'fill out the main sheet with the extracted data from the workout sheet

    ActiveSheet.Cells(finalrow, 1).FormulaR1C1 = "=Workout!R[2]C[9]"
    ActiveSheet.Cells(finalrow, 2).FormulaR1C1 = "=Workout!R[2]C[11]"
    ActiveSheet.Cells(finalrow, 3).FormulaR1C1 = "=Workout!R[-2]C[11]"
    ActiveSheet.Cells(finalrow, 6).FormulaR1C1 = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(finalrow, 7).FormulaR1C1 = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(finalrow, 9).FormulaR1C1 = "=Workout!R[-2]C[8]"
    ActiveSheet.Cells(finalrow, 10).FormulaR1C1 = "=""blabla"""
    ActiveSheet.Cells(finalrow, 13).FormulaR1C1 = "=Workout!R[-2]C[9]"

rcountera = rcountera + 1

finalrow = finalrow + 1

Loop

End Sub

Can anyone assist me with this as I am really stumped?
Thanks
Andy

Hi, Andy.
Try replacing this piece of the second code you posted above

    ActiveSheet.Cells(finalrow, 1).FormulaR1C1 = "=Workout!R[2]C[9]"
    ActiveSheet.Cells(finalrow, 2).FormulaR1C1 = "=Workout!R[2]C[11]"
    ActiveSheet.Cells(finalrow, 3).FormulaR1C1 = "=Workout!R[-2]C[11]"
    ActiveSheet.Cells(finalrow, 6).FormulaR1C1 = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(finalrow, 7).FormulaR1C1 = "=Workout!R[-2]C[9]"
    ActiveSheet.Cells(finalrow, 9).FormulaR1C1 = "=Workout!R[-2]C[8]"
    ActiveSheet.Cells(finalrow, 10).FormulaR1C1 = "=""blabla"""
    ActiveSheet.Cells(finalrow, 13).FormulaR1C1 = "=Workout!R[-2]C[9]"

By this

    ActiveSheet.Cells(finalrow, 1).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[9]"
    ActiveSheet.Cells(finalrow, 2).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[11]"
    ActiveSheet.Cells(finalrow, 3).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[9]"
    ActiveSheet.Cells(finalrow, 6).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[9]"
    ActiveSheet.Cells(finalrow, 7).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[9]"
    ActiveSheet.Cells(finalrow, 9).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[8]"
    ActiveSheet.Cells(finalrow, 10).FormulaR1C1 = "=""blabla"""
    ActiveSheet.Cells(finalrow, 13).FormulaR1C1 = "=Workout!R[" & -finalrow + rcountera & "]C[9]"

This will continue inserting formulae, tell us if you prefer the values instead.

What I meant is: your code pulls some information from a sheet and put it in another. It was written to perform this task through formulae. So if there are changes in the source worksheet the result of the formula will be updated. If you will not use this feature then you can rewrite the code to pull the values ​​directly, this way the values will not be upgraded until you run the code again.

If you want try this way, change that same piece of code to this (which could be simplified later):

    ActiveSheet.Cells(finalrow, 1).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 10).Value
    ActiveSheet.Cells(finalrow, 2).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 13).Value
    ActiveSheet.Cells(finalrow, 3).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 12).Value
    ActiveSheet.Cells(finalrow, 6).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 15).Value
    ActiveSheet.Cells(finalrow, 7).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 16).Value
    ActiveSheet.Cells(finalrow, 9).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 17).Value
    ActiveSheet.Cells(finalrow, 10).FormulaR1C1 = "=""blabla"""
    ActiveSheet.Cells(finalrow, 13).FormulaR1C1 = Sheets("Workout").Cells(rcountera, 22).Value