none
data transformation VBA RRS feed

  • Question

  • Hi All

    I need to transform the below data with Spread numbers...

    (The data are in my ActiveWorksheet)


    ...to get the one looks like this :


    -> Data output can be created in a new worksheet "SECTIONS"

    -> Grey out row/column are only for your information and do not have to be modify.

    -> The above data are a part of bigger table with much more rows and columns

    -> Spread can be only even number!  for example:(2,4,6,8,...) 

    -> As you can notice for "FC" and "BL" there are more rows in output table, that's because "FC" includes also all spreads between FC(START) and FC(END) 

    I hope that's enough information to understand this case.

    Thanks in advance

    G.

    Tuesday, September 22, 2015 2:13 PM

Answers

  • Sorry, I had a hiccup when pasting some of the code.

    This version will ask you to select the cells with A,B,C (however many you have). Do not select the header, or the entire column, just the cells

    Sub TestMacro()
        Dim rngC As Range
        Dim wsT As Worksheet
        Dim wsS As Worksheet
        Dim i() As Integer
        Dim c As Integer
        Dim j As Integer
        Dim k As Integer
        Dim lR As Long
        
        
        Set rngC = Application.InputBox("Select the cells with the Market names", Type:=8)
        Set wsT = rngC.Parent
        c = rngC.Cells.Count
        ReDim i(1 To c)
        
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Sections").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        
        Set wsS = Worksheets.Add
        wsS.Name = "Sections"
        wsS.Range("A1").Value = "Market"
        wsS.Range("B1").Value = "Spread"
        wsS.Range("C1").Value = "Section"
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BM").Value
        Next j
        
    LoopAgain:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BN").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "FC"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished
            Next k
            GoTo FinishedFC
    NotFinished:
        Next j
        GoTo LoopAgain
    FinishedFC:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BO").Value
            wsS.Cells(lR, "C").Value = "CS"
        Next j
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BQ").Value
        Next j
        
        
    LoopAgain2:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BR").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "BL"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished2
            Next k
            GoTo FinishedBL
    NotFinished2:
        Next j
        GoTo LoopAgain2
    FinishedBL:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BS").Value
            wsS.Cells(lR, "C").Value = "Cover"
        Next j
        
        
        With wsS.Range("A1").CurrentRegion
            .HorizontalAlignment = xlCenter
           .Cells.Borders.LineStyle = xlContinuous
        End With
    End Sub

    Wednesday, September 23, 2015 1:34 PM

All replies

  • Select the cells with A,B,C (however many you have) and run this macro: It does not apply the color formatting, but the values should work....

    Sub TestMacro()
        Dim rngC As Range
        Dim wsT As Worksheet
        Dim wsS As Worksheet
        Dim i() As Integer
        Dim c As Integer
        Dim j As Integer
        Dim k As Integer
        Dim lR As Long
        
        Set wsT = ActiveSheet
        Set rngC = Selection
        c = rngC.Cells.Count
        ReDim i(1 To c)
        
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Sections").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        
        Set wsS = Worksheets.Add
        wsS.Name = "Sections"
        wsS.Range("A1").Value = "Market"
        wsS.Range("B1").Value = "Spread"
        wsS.Range("C1").Value = "Section"
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BM").Value
        Next j
        
    LoopAgain:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BN").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "FC"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished
            Next k
            GoTo FinishedFC
    NotFinished:
        Next j
        GoTo LoopAgain
    FinishedFC:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BO").Value
            wsS.Cells(lR, "C").Value = "CS"
        Next j
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BQ").Value
        Next j
        
        
    LoopAgain2:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BR").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "BL"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished2
            Next k
            GoTo FinishedBL
    NotFinished2:
        Next j
        GoTo LoopAgain2
    FinishedBL:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BS").Value
            wsS.Cells(lR, "C").Value = "Cover"
        Next j
        
        
        With wsS.Range("A1").CurrentRegion
            .HorizontalAlignment = xlCenter
          
        With wsS.Range("A1").CurrentRegion
            .HorizontalAlignment = xlCenter
           .Cells.Borders.LineStyle = xlContinuous
        End With
    End Sub

    Tuesday, September 22, 2015 3:38 PM
  • Thanks Bernie

    What do you mean "Select the cells with A,B,C "? You mean "Market" column? Full or only up to the last row?

    If I do this the below error will occur in the last line of the code: 

    Is it possible to include the operation with "Select the cells with A,B,C " into the code?

    Wednesday, September 23, 2015 8:11 AM
  • Sorry, I had a hiccup when pasting some of the code.

    This version will ask you to select the cells with A,B,C (however many you have). Do not select the header, or the entire column, just the cells

    Sub TestMacro()
        Dim rngC As Range
        Dim wsT As Worksheet
        Dim wsS As Worksheet
        Dim i() As Integer
        Dim c As Integer
        Dim j As Integer
        Dim k As Integer
        Dim lR As Long
        
        
        Set rngC = Application.InputBox("Select the cells with the Market names", Type:=8)
        Set wsT = rngC.Parent
        c = rngC.Cells.Count
        ReDim i(1 To c)
        
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Sections").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        
        Set wsS = Worksheets.Add
        wsS.Name = "Sections"
        wsS.Range("A1").Value = "Market"
        wsS.Range("B1").Value = "Spread"
        wsS.Range("C1").Value = "Section"
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BM").Value
        Next j
        
    LoopAgain:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BN").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "FC"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished
            Next k
            GoTo FinishedFC
    NotFinished:
        Next j
        GoTo LoopAgain
    FinishedFC:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BO").Value
            wsS.Cells(lR, "C").Value = "CS"
        Next j
        
        For j = 1 To c
            i(j) = wsT.Cells(rngC.Cells(j).Row, "BQ").Value
        Next j
        
        
    LoopAgain2:
        For j = 1 To c
            If i(j) <> 0 Then
                If i(j) <= wsT.Cells(rngC.Cells(j).Row, "BR").Value Then
                    lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
                    wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
                    wsS.Cells(lR, "B").Value = i(j)
                    wsS.Cells(lR, "C").Value = "BL"
                    i(j) = i(j) + 2
                Else
                    i(j) = 0
                End If
            End If
            For k = 1 To c
                If i(k) <> 0 Then GoTo NotFinished2
            Next k
            GoTo FinishedBL
    NotFinished2:
        Next j
        GoTo LoopAgain2
    FinishedBL:
        
        For j = 1 To c
            lR = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
            wsS.Cells(lR, "A").Value = rngC.Cells(j).Value
            wsS.Cells(lR, "B").Value = wsT.Cells(rngC.Cells(j).Row, "BS").Value
            wsS.Cells(lR, "C").Value = "Cover"
        Next j
        
        
        With wsS.Range("A1").CurrentRegion
            .HorizontalAlignment = xlCenter
           .Cells.Borders.LineStyle = xlContinuous
        End With
    End Sub

    Wednesday, September 23, 2015 1:34 PM