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
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,166
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
 

Andy booth

New Member
Joined
Feb 12, 2013
Messages
7
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
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,166
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
 

Forum statistics

Threads
1,081,702
Messages
5,360,743
Members
400,595
Latest member
T_Dubs

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top