VBA macro to extract data from one row to two rows

Andy booth

New Member
Joined
Feb 12, 2013
Messages
7
Hi,

I am trying to extract certain columns from a calculated row on a worksheet and generate two new rows derived from the original calculated row.

Calculated data looks like this.
75EUREURXXXXXC5555D02/12/201375blabla555586938693
40GBPGBPXXXXXD6666C02/12/201340blabla666686958695
162USDXXXXXD13332C02/12/2013162blabla1333220512051
62HKDHKDXXXXXC7777D02/12/201362blabla777720482048

<colgroup><col><col><col span="2"><col><col><col><col span="2"><col><col span="2"><col><col></colgroup><tbody>
</tbody>

The extracted data should look like this, so for the 4 rows above I will get 8 rows below.

EUREURXXXXXC02/12/201375blabla55558693
GBPGBPXXXXXD02/12/201340blabla66668695
USDXXXXXD02/12/2013162blabla133322051
HKDHKDXXXXXC02/12/201362blabla77772048
EUR5555D 02/12/201375 blabla 8693
GBP6666C 02/12/201340 blabla 8695
13332C 02/12/2013 162blabla 2051
HKD7777D 02/12/201362 blabla 2048

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>


If I only have one original line my code worked ok, however, when I have say 4 original rows the 1st line of extracted data comes out ok but the second line does not. 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

Can someone take a look and possibly point me in the right direction?

Thanks
Andy


Code:
Sub workout_details()




Dim rcounter As Integer


Worksheets("Workout").Activate
rcounter = 2
Do While ActiveSheet.Cells(rcounter, 5) <> ""


On Error Resume Next




    ActiveSheet.Cells(rcounter, 9).Formula = "=ABS(RC[-4])"
    ActiveSheet.Cells(rcounter, 10).Formula = "=IF(RC[-7]=""USD"","""",RC[-7])"
    ActiveSheet.Cells(rcounter, 11).Formula = "=VLOOKUP(RC[-8],matrix,2)"
    ActiveSheet.Cells(rcounter, 12).Formula = "=IF(RC[2]=""D"",""C"",""D"")"
    ActiveSheet.Cells(rcounter, 13).Formula = "=VLOOKUP(RC[-10],matrix,3)"
    ActiveSheet.Cells(rcounter, 14).Formula = "=IF(RC[-9]>0,""D"",""C"")"
    ActiveSheet.Cells(rcounter, 15).Formula = "=R2C1"
    ActiveSheet.Cells(rcounter, 16).Formula = "=IF(RC[-13]=""USD"","""",RC[-7])"
    ActiveSheet.Cells(rcounter, 17).Formula = "=IF(RC[-14]=""USD"",RC[-8],"""")"
    ActiveSheet.Cells(rcounter, 18).Formula = "=""blabla"""
    ActiveSheet.Cells(rcounter, 21).Formula = "=VLOOKUP(RC[-18],matrix,5)"
    ActiveSheet.Cells(rcounter, 22).Formula = "=VLOOKUP(RC[-19],matrix,4)"
    ActiveSheet.Cells(rcounter, 24).Formula = "=VLOOKUP(RC[-21],matrix,8)"
    ActiveSheet.Cells(rcounter, 25).Formula = ConvertamttoUSD(ActiveSheet.Cells(rcounter, 3).Value)
    ActiveSheet.Cells(rcounter, 26).Formula = "=VLOOKUP(RC[-23],matrix,6)"
    
rcounter = rcounter + 1
Application.Calculate


Loop


End Sub
Sub clrworkout()


    Worksheets("Workout").Activate
    Range("i2", "aa300").Clear
    Range("i2").Select


End Sub


Sub createintl()




Dim rcounter As Integer
Dim rcountera As Integer


Worksheets("Main").Activate
rcountera = 2
rcounter = 4


Do While Worksheets("Workout").Cells(rcountera, 5) <> ""


On Error Resume Next


    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
Sub createnos()




Dim rcounter As Integer
Dim rcountera As Integer




Worksheets("Main").Activate
rcountera = 2


finalrow = Cells(65536, 2).End(xlUp).Row + 1


Do While Worksheets("Workout").Cells(rcountera, 5) <> ""


On Error Resume Next






    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


Sub createjnls()
    Call clrworkout
    Call workout_details


    Call clrold
    
    Call createintl
    Call createnos


Worksheets("Workout").Activate


Msgbox "Journals have been created"




End Sub


Sub clrold()
    Worksheets("Main").Activate
    Range("a4", "n100").Clear
    Range("a1").Select
End Sub


Sub srtjnls()


    Range("a4", "n100").Select
     ActiveWorkbook.Worksheets("Journal WFBI").Sort.SortFields.Add Key:=Range( _
        "A4:A100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
End Sub




Public Function ConvertamttoUSD(ByVal scurr As String) As String


    If scurr = "EUR" Then
    ConvertamttoUSD = "=rc[-16] * EUR"
    ElseIf scurr = "GBP" Then
    ConvertamttoUSD = "=rc[-16] * GBP"
    ElseIf scurr = "USD" Then
    ConvertamttoUSD = "=rc[-16] * USD"
    ElseIf scurr = "NZD" Then
    ConvertamttoUSD = "=rc[-16] * NZD"
    ElseIf scurr = "AUD" Then
    ConvertamttoUSD = "=rc[-16] * AUD"
    
    ElseIf scurr = "SEK" Then
    ConvertamttoUSD = "=rc[-16] / SEK"
    ElseIf scurr = "NOK" Then
    ConvertamttoUSD = "=rc[-16] / NOK"
    ElseIf scurr = "CHF" Then
    ConvertamttoUSD = "=rc[-16] / CHF"
    ElseIf scurr = "CAD" Then
    ConvertamttoUSD = "=rc[-16] / CAD"
    ElseIf scurr = "DKK" Then
    ConvertamttoUSD = "=rc[-16] / DKK"
    ElseIf scurr = "CHF" Then
    ConvertamttoUSD = "=rc[-16] / CHF"
    ElseIf scurr = "JPY" Then
    ConvertamttoUSD = "=rc[-16] / JPY"
    ElseIf scurr = "HKD" Then
    ConvertamttoUSD = "=rc[-16] / HKD"
      
    End If
End Function
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
I don't understand everything you are doing, but I think you want something like this...

Code:
Sub createnos()
    
    Dim rcounter As Integer
    Dim rcountera As Integer
[COLOR=#ff0000]    Dim MyOffset As Long[/COLOR]
    
    Worksheets("Main").Activate
    rcountera = 2
    
    FinalRow = Cells(65536, 2).End(xlUp).Row + 1
[COLOR=#ff0000]    MyOffset = rcountera  - FinalRow[/COLOR]
    
    Do While Worksheets("Workout").Cells(rcountera, 5) <> ""
    
        On Error Resume Next
    
        ActiveSheet.Cells(FinalRow, 1).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 2).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[11]"
        ActiveSheet.Cells(FinalRow, 3).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[11]"
        ActiveSheet.Cells(FinalRow, 6).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 7).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 9).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[8]"
        ActiveSheet.Cells(FinalRow, 10).FormulaR1C1 = "=""blabla"""
        ActiveSheet.Cells(FinalRow, 13).FormulaR1C1 = "=Workout!R[[COLOR=#FF0000]" & MyOffset & "[/COLOR]]C[9]"
    
        rcountera = rcountera + 1
        FinalRow = FinalRow + 1
        
    Loop
    
End Sub
 
Upvote 0
That worked perfectly.....thanks for the help.

What does putting that in do in simple terms...."MyOffset = rcountera - FinalRow"




I don't understand everything you are doing, but I think you want something like this...

Code:
Sub createnos()
    
    Dim rcounter As Integer
    Dim rcountera As Integer
[COLOR=#ff0000]    Dim MyOffset As Long[/COLOR]
    
    Worksheets("Main").Activate
    rcountera = 2
    
    FinalRow = Cells(65536, 2).End(xlUp).Row + 1
[COLOR=#ff0000]    MyOffset = rcountera  - FinalRow[/COLOR]
    
    Do While Worksheets("Workout").Cells(rcountera, 5) <> ""
    
        On Error Resume Next
    
        ActiveSheet.Cells(FinalRow, 1).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 2).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[11]"
        ActiveSheet.Cells(FinalRow, 3).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[11]"
        ActiveSheet.Cells(FinalRow, 6).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 7).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[9]"
        ActiveSheet.Cells(FinalRow, 9).FormulaR1C1 = "=Workout!R[[COLOR=#ff0000]" & MyOffset & "[/COLOR]]C[8]"
        ActiveSheet.Cells(FinalRow, 10).FormulaR1C1 = "=""blabla"""
        ActiveSheet.Cells(FinalRow, 13).FormulaR1C1 = "=Workout!R[[COLOR=#FF0000]" & MyOffset & "[/COLOR]]C[9]"
    
        rcountera = rcountera + 1
        FinalRow = FinalRow + 1
        
    Loop
    
End Sub
 
Upvote 0
That worked perfectly.....thanks for the help.

What does putting that in do in simple terms...."MyOffset = rcountera - FinalRow"

You're welcome.

It calculates the offset needed to get to row 2 (rcountera) from the FinalRow
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,937
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top