VBA macro to extract data from one row to two rows

A

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.
[TABLE="width: 1119"]
<colgroup><col><col><col span="2"><col><col><col><col span="2"><col><col span="2"><col><col></colgroup><tbody>[TR]
[TD="align: right"]75[/TD]
[TD]EUR[/TD]
[TD]EURXXXXX[/TD]
[TD]C[/TD]
[TD="align: right"]5555[/TD]
[TD]D[/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]75[/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]55558693[/TD]
[TD="align: right"]8693[/TD]
[/TR]
[TR]
[TD="align: right"]40[/TD]
[TD]GBP[/TD]
[TD]GBPXXXXX[/TD]
[TD]D[/TD]
[TD="align: right"]6666[/TD]
[TD]C[/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]40[/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]66668695[/TD]
[TD="align: right"]8695[/TD]
[/TR]
[TR]
[TD="align: right"]162[/TD]
[TD][/TD]
[TD]USDXXXXX[/TD]
[TD]D[/TD]
[TD="align: right"]13332[/TD]
[TD]C[/TD]
[TD="align: right"]02/12/2013[/TD]
[TD][/TD]
[TD="align: right"]162[/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]133322051[/TD]
[TD="align: right"]2051[/TD]
[/TR]
[TR]
[TD="align: right"]62[/TD]
[TD]HKD[/TD]
[TD]HKDXXXXX[/TD]
[TD]C[/TD]
[TD="align: right"]7777[/TD]
[TD]D[/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]62[/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]77772048[/TD]
[TD="align: right"]2048[/TD]
[/TR]
</tbody>[/TABLE]

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

[TABLE="width: 1496"]
<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]EUR[/TD]
[TD]EURXXXXX[/TD]
[TD]C[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]75[/TD]
[TD][/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]55558693[/TD]
[/TR]
[TR]
[TD]GBP[/TD]
[TD]GBPXXXXX[/TD]
[TD]D[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]40[/TD]
[TD][/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]66668695[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]USDXXXXX[/TD]
[TD]D[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]02/12/2013[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]162[/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]133322051[/TD]
[/TR]
[TR]
[TD]HKD[/TD]
[TD]HKDXXXXX[/TD]
[TD]C[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]62[/TD]
[TD][/TD]
[TD][/TD]
[TD]blabla[/TD]
[TD][/TD]
[TD][/TD]
[TD]77772048[/TD]
[/TR]
[TR]
[TD]EUR[/TD]
[TD="align: right"]5555[/TD]
[TD]D[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]75[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]blabla[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]8693[/TD]
[/TR]
[TR]
[TD]GBP[/TD]
[TD="align: right"]6666[/TD]
[TD]C[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]40[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]blabla[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]8695[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD="align: right"]13332[/TD]
[TD]C[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]02/12/2013[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]162[/TD]
[TD]blabla[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]2051[/TD]
[/TR]
[TR]
[TD]HKD[/TD]
[TD="align: right"]7777[/TD]
[TD]D[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]02/12/2013[/TD]
[TD="align: right"]62[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]blabla[/TD]
[TD] [/TD]
[TD] [/TD]
[TD="align: right"]2048[/TD]
[/TR]
</tbody>[/TABLE]


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

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
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"




AlphaFrog said:
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
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

Sufiyan97
  • Solved
VBA Filter Names from List One by One and then Copy filtered data v2
Replies
6
Views
175
Sufiyan97
Sufiyan97
Lantern
  • Question Question
Excel VBA Loop through Column Range to Mark Section Headers
2
Replies
16
Views
865
Akuini
Akuini
S
  • Question Question
How to create a proper excel table from unorganized data?
Replies
5
Views
321
Burrgogi
Burrgogi
M
  • Question Question
Extract data from Word to Excel
Replies
1
Views
1K
MHamid
M
D
  • Question Question
VBA to Populate an Issue Status Cell
Replies
0
Views
381
Desiato34
D

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

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