Rearranging the Data based on condition

Negi1984

Board Regular
Joined
May 6, 2011
Messages
197
Hi All,

I have raw data in below format around 20K to 30K rows and I need to rearrange the rows based on below mentioned condition :-

1) I need to filter on Ring name for example I filter Ring A05.
2) Then I filter 1 by 1 to ATN loop back column for example : I filter 10.35.201.1.
3) Then I need to arrange interface description(colum G) containing "GigabitEthernet0/2/16" orGigabitEthernet0/2/0 always in starting(top) of the data of that particularATN loop back filter .
4) Then I need to arrange interface description(colum G) containing "GigabitEthernet0/2/17" orGigabitEthernet0/2/1 always in Last of the data of that particularATN loop back filter .
5) Then I need to conditional format the rows in two colors.
i) if its starting row and End of any different Ring then that row needs to be filled with dark grey color.
ii) if its starting and end of any different ATN ring then that row needs to be filled with light grey color.

6) If any of the condition not satisfied mentioned in point 3 & 4 then no sorting required, Just I need to marked those ATN IP in Red color.

I also attached the sample file and output result sample in below given link.

http://1drv.ms/1KLXmmj

Can anybody suggest me any Advance sorting or Macro based solution for the same. currently its taking almost 2 days to arrange the data in this format.

Thanks in advance for your valuable suggestions.

Regards,
Rajender
 

Some videos you may like

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

RickXL

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,316
Hi,

I can offer this as a starting point.

The process is:

1. Copy all the data into an array in VBA.
2. Create a string which when sorted will place all the rows in the correct order.
3. When creating that string remember the associated row number.
4. Sort the list and the numbers into order.
5. Create an output array in the order specified by the sorted list.
6. Write the output array to a new worksheet (Test Output).
7. Apply the formatting.

Code:
Sub ATN_Report_Formatting()

    Dim ws1      As Worksheet
    Dim ws2      As Worksheet
    Dim i        As Long
    Dim j        As Long
    Dim iOut     As Long
    Dim arr1     As Variant
    Dim arr2     As Variant
    Dim sl       As Object
    Dim srtKey   As String
    Dim Key      As String
    Dim lastRing As String
    Dim r        As Range
    Dim fc       As FormatCondition

    Set ws1 = ThisWorkbook.Worksheets("Raw Data")
    Set ws2 = ThisWorkbook.Worksheets("Test Output")
    
    Set sl = CreateObject("System.Collections.SortedList")

    With ws1
        ' Get the Raw Data and create an output array
        arr1 = .Range("A6:AD" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
        ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))
        
        ' Create the sort order
        sl.Capacity = UBound(arr1, 1)
        For i = 1 To UBound(arr1, 1)
            lastRing = vbNullString
            If InStr(arr1(i, 7), ".") > 0 Then Key = Left(arr1(i, 7), InStr(arr1(i, 7), ".") - 1) & "/" Else Key = arr1(i, 7) & "/"
            Select Case Key
                Case "GigabitEthernet0/2/16/": srtKey = "000000"
                Case "GigabitEthernet0/2/0/":  srtKey = "000000"
                Case "GigabitEthernet0/2/17/": srtKey = "999999"
                Case "GigabitEthernet0/2/1/":  srtKey = "999999"
                Case Else: srtKey = Format(i, "000000")
            End Select
            sl.Add arr1(i, 1) & Chr(0) & arr1(i, 2) & Chr(0) & srtKey & Chr(0) & arr1(i, 7), i
        Next

        ' Write the output array in the correct order
        For iOut = 1 To UBound(arr1, 1)
            i = sl.GetByIndex(iOut - 1)
            For j = 1 To UBound(arr1, 2)
                arr2(iOut, j) = arr1(i, j)
            Next
        Next
    End With
    
    With ws2
        ' Clear the Output Sheet
        .Cells.Clear
        
        ' Copy the headings from the Raw Data sheet
        ws1.Range("A1:AD5").Copy
        With .Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
        End With
        Application.CutCopyMode = False
        
        ' Insert the Sorted Data
        .Range("A6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
        
        ' Start the Formatting
        With .Range("A6:AD" & UBound(arr2, 1) + 5)
            ' Centre the data
            .HorizontalAlignment = xlCenter
            
            ' Clear Conditional Formatting
            .FormatConditions.Delete

            ' CF for New Ring
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$A5<>$A6")
            fc.Interior.Color = RGB(196, 189, 151)
            fc.Borders(xlTop).LineStyle = xlDash
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$A6<>$A7")
            fc.Interior.Color = RGB(196, 189, 151)
            
            ' CF for New ATN IP Loopback
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$B5<>$B6")
            fc.Interior.Color = RGB(217, 217, 217)
            fc.Borders(xlTop).LineStyle = xlDash
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$B6<>$B7")
            fc.Interior.Color = RGB(217, 217, 217)
            
        End With
    End With
End Sub

I am not sure what to do about the red rows. Perhaps if you could create an example I could code it.
 

Negi1984

Board Regular
Joined
May 6, 2011
Messages
197
Hi Rick,Thanks a ton :) .Its really save my too much manual effort for checking and arranging.I am cross checking the output manually this time. if all the output result is fine or not ?In between I also want to know if in case I remove or add any column from this format then this macro still work or not ?
Hi,I can offer this as a starting point.The process is:1. Copy all the data into an array in VBA.2. Create a string which when sorted will place all the rows in the correct order.3. When creating that string remember the associated row number.4. Sort the list and the numbers into order.5. Create an output array in the order specified by the sorted list.6. Write the output array to a new worksheet (Test Output).7. Apply the formatting.
Code:
Sub ATN_Report_Formatting()    Dim ws1      As Worksheet    Dim ws2      As Worksheet    Dim i        As Long    Dim j        As Long    Dim iOut     As Long    Dim arr1     As Variant    Dim arr2     As Variant    Dim sl       As Object    Dim srtKey   As String    Dim Key      As String    Dim lastRing As String    Dim r        As Range    Dim fc       As FormatCondition    Set ws1 = ThisWorkbook.Worksheets("Raw Data")    Set ws2 = ThisWorkbook.Worksheets("Test Output")        Set sl = CreateObject("System.Collections.SortedList")    With ws1        ' Get the Raw Data and create an output array        arr1 = .Range("A6:AD" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value        ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))                ' Create the sort order        sl.Capacity = UBound(arr1, 1)        For i = 1 To UBound(arr1, 1)            lastRing = vbNullString            If InStr(arr1(i, 7), ".") > 0 Then Key = Left(arr1(i, 7), InStr(arr1(i, 7), ".") - 1) & "/" Else Key = arr1(i, 7) & "/"            Select Case Key                Case "GigabitEthernet0/2/16/": srtKey = "000000"                Case "GigabitEthernet0/2/0/":  srtKey = "000000"                Case "GigabitEthernet0/2/17/": srtKey = "999999"                Case "GigabitEthernet0/2/1/":  srtKey = "999999"                Case Else: srtKey = Format(i, "000000")            End Select            sl.Add arr1(i, 1) & Chr(0) & arr1(i, 2) & Chr(0) & srtKey & Chr(0) & arr1(i, 7), i        Next        ' Write the output array in the correct order        For iOut = 1 To UBound(arr1, 1)            i = sl.GetByIndex(iOut - 1)            For j = 1 To UBound(arr1, 2)                arr2(iOut, j) = arr1(i, j)            Next        Next    End With        With ws2        ' Clear the Output Sheet        .Cells.Clear                ' Copy the headings from the Raw Data sheet        ws1.Range("A1:AD5").Copy        With .Range("A1")            .PasteSpecial xlPasteColumnWidths            .PasteSpecial xlPasteValues, , False, False            .PasteSpecial xlPasteFormats, , False, False        End With        Application.CutCopyMode = False                ' Insert the Sorted Data        .Range("A6").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2                ' Start the Formatting        With .Range("A6:AD" & UBound(arr2, 1) + 5)            ' Centre the data            .HorizontalAlignment = xlCenter                        ' Clear Conditional Formatting            .FormatConditions.Delete            ' CF for New Ring            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$A5<>$A6")            fc.Interior.Color = RGB(196, 189, 151)            fc.Borders(xlTop).LineStyle = xlDash            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$A6<>$A7")            fc.Interior.Color = RGB(196, 189, 151)                        ' CF for New ATN IP Loopback            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$B5<>$B6")            fc.Interior.Color = RGB(217, 217, 217)            fc.Borders(xlTop).LineStyle = xlDash            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=$B6<>$B7")            fc.Interior.Color = RGB(217, 217, 217)                    End With    End WithEnd Sub
I am not sure what to do about the red rows. Perhaps if you could create an example I could code it.
Regards,Rajender
 

RickXL

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,316
Hi,

The old code had several referenced to column AD. I think you would need to change all those if you altered the number of columns.

However, I have made some changes. It now looks for the first occurrence of the word "Ring" in the spreadsheet. It assumes that is the top left hand header cell. This need not be in column A.

Everything else, including the conditional formatting is now calculated by the macro. The last column is determined by the last used header column. The number of rows is determined by the last occupied row under the Ring heading.

Code:
Sub ATN_Report_Formatting()

    Dim ws1      As Worksheet
    Dim ws2      As Worksheet
    Dim i        As Long
    Dim j        As Long
    Dim iOut     As Long
    Dim arr1     As Variant
    Dim arr2     As Variant
    Dim sl       As Object
    Dim srtKey   As String
    Dim Key      As String
    Dim fc       As FormatCondition
    Dim finCol   As Long               ' Final column - Calculated from heading row
    Dim finRow   As Long               ' Final used row number - Calculated from first used column
    Dim dtaRange As Range              ' Complete data range - Calculated
    Dim hdrRange As Range              ' Complete header range - Calculated
    Dim cfForm   As String
    
    Set ws1 = ThisWorkbook.Worksheets("Raw Data")
    Set ws2 = ThisWorkbook.Worksheets("Test Output")
    
    Set sl = CreateObject("System.Collections.SortedList")

    With ws1
        ' Locate the first cell with "Ring" in it
        Set hdrRange = .Cells.Find(What:="Ring", After:=[A1], SearchOrder:=xlByRows)
        
        ' Get the Raw Data and create an output array
        finCol = .Cells(hdrRange.Row, .Columns.Count).End(xlToLeft).Column
        finRow = .Cells(.Rows.Count, hdrRange.Column).End(xlUp).Row
        arr1 = .Range(hdrRange.Offset(1), .Cells(finRow, finCol))
        ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))
        
        ' Create the sort order
        sl.Capacity = UBound(arr1, 1)
        For i = 1 To UBound(arr1, 1)
            If InStr(arr1(i, 7), ".") > 0 Then Key = Left(arr1(i, 7), InStr(arr1(i, 7), ".") - 1) & "/" Else Key = arr1(i, 7) & "/"
            Select Case Key
                Case "GigabitEthernet0/2/16/": srtKey = "000000"
                Case "GigabitEthernet0/2/0/":  srtKey = "000000"
                Case "GigabitEthernet0/2/17/": srtKey = "999999"
                Case "GigabitEthernet0/2/1/":  srtKey = "999999"
                Case Else: srtKey = Format(i, "000000")
            End Select
            sl.Add arr1(i, 1) & Chr(0) & arr1(i, 2) & Chr(0) & srtKey & Chr(0) & arr1(i, 7), i
        Next

        ' Write the output array in the correct order
        For iOut = 1 To UBound(arr1, 1)
            i = sl.GetByIndex(iOut - 1)
            For j = 1 To UBound(arr1, 2)
                arr2(iOut, j) = arr1(i, j)
            Next
        Next
    End With
    
    With ws2
        ' Clear the Output Sheet
        .Cells.Clear
        
        ' Copy the headings from the Raw Data sheet
        ws1.Range("A1").Resize(hdrRange.Row, finCol).Copy
        With .Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        
        ' Insert the Sorted Data
        Set dtaRange = .Range(.Cells(hdrRange.Row + 1, hdrRange.Column), .Cells(finRow, finCol))
        dtaRange = arr2
        
        ' Start the Formatting
        With dtaRange
            ' Centre the data
            .HorizontalAlignment = xlCenter
            
            ' Clear Conditional Formatting
            .FormatConditions.Delete

            ' CF for First Ring
            cfForm = Application.ConvertFormula("=R[-1]C<>RC", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(1, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(196, 189, 151)
            fc.Borders(xlTop).LineStyle = xlDash
            
            ' CF for Last Ring
            cfForm = Application.ConvertFormula("=R[-1]C<>RC", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(2, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(196, 189, 151)
            
            ' CF for First ATN IP Loopback
            cfForm = Application.ConvertFormula("=R[-1]C[1]<>RC[1]", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(1, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(217, 217, 217)
            fc.Borders(xlTop).LineStyle = xlDash
                        
            ' CF for Last ATN IP Loopback
            cfForm = Application.ConvertFormula("=R[-1]C[1]<>RC[1]", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(2, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(217, 217, 217)
            
        End With
    End With
End Sub
 

Negi1984

Board Regular
Joined
May 6, 2011
Messages
197
Hi Rick,

Thanks a lot once again for your support :).
It really very helpful and appriciated by my team members also.
All credit goes to you :)

Regards,
Rajender
Hi,

The old code had several referenced to column AD. I think you would need to change all those if you altered the number of columns.

However, I have made some changes. It now looks for the first occurrence of the word "Ring" in the spreadsheet. It assumes that is the top left hand header cell. This need not be in column A.

Everything else, including the conditional formatting is now calculated by the macro. The last column is determined by the last used header column. The number of rows is determined by the last occupied row under the Ring heading.

Code:
Sub ATN_Report_Formatting()

    Dim ws1      As Worksheet
    Dim ws2      As Worksheet
    Dim i        As Long
    Dim j        As Long
    Dim iOut     As Long
    Dim arr1     As Variant
    Dim arr2     As Variant
    Dim sl       As Object
    Dim srtKey   As String
    Dim Key      As String
    Dim fc       As FormatCondition
    Dim finCol   As Long               ' Final column - Calculated from heading row
    Dim finRow   As Long               ' Final used row number - Calculated from first used column
    Dim dtaRange As Range              ' Complete data range - Calculated
    Dim hdrRange As Range              ' Complete header range - Calculated
    Dim cfForm   As String
    
    Set ws1 = ThisWorkbook.Worksheets("Raw Data")
    Set ws2 = ThisWorkbook.Worksheets("Test Output")
    
    Set sl = CreateObject("System.Collections.SortedList")

    With ws1
        ' Locate the first cell with "Ring" in it
        Set hdrRange = .Cells.Find(What:="Ring", After:=[A1], SearchOrder:=xlByRows)
        
        ' Get the Raw Data and create an output array
        finCol = .Cells(hdrRange.Row, .Columns.Count).End(xlToLeft).Column
        finRow = .Cells(.Rows.Count, hdrRange.Column).End(xlUp).Row
        arr1 = .Range(hdrRange.Offset(1), .Cells(finRow, finCol))
        ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))
        
        ' Create the sort order
        sl.Capacity = UBound(arr1, 1)
        For i = 1 To UBound(arr1, 1)
            If InStr(arr1(i, 7), ".") > 0 Then Key = Left(arr1(i, 7), InStr(arr1(i, 7), ".") - 1) & "/" Else Key = arr1(i, 7) & "/"
            Select Case Key
                Case "GigabitEthernet0/2/16/": srtKey = "000000"
                Case "GigabitEthernet0/2/0/":  srtKey = "000000"
                Case "GigabitEthernet0/2/17/": srtKey = "999999"
                Case "GigabitEthernet0/2/1/":  srtKey = "999999"
                Case Else: srtKey = Format(i, "000000")
            End Select
            sl.Add arr1(i, 1) & Chr(0) & arr1(i, 2) & Chr(0) & srtKey & Chr(0) & arr1(i, 7), i
        Next

        ' Write the output array in the correct order
        For iOut = 1 To UBound(arr1, 1)
            i = sl.GetByIndex(iOut - 1)
            For j = 1 To UBound(arr1, 2)
                arr2(iOut, j) = arr1(i, j)
            Next
        Next
    End With
    
    With ws2
        ' Clear the Output Sheet
        .Cells.Clear
        
        ' Copy the headings from the Raw Data sheet
        ws1.Range("A1").Resize(hdrRange.Row, finCol).Copy
        With .Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        
        ' Insert the Sorted Data
        Set dtaRange = .Range(.Cells(hdrRange.Row + 1, hdrRange.Column), .Cells(finRow, finCol))
        dtaRange = arr2
        
        ' Start the Formatting
        With dtaRange
            ' Centre the data
            .HorizontalAlignment = xlCenter
            
            ' Clear Conditional Formatting
            .FormatConditions.Delete

            ' CF for First Ring
            cfForm = Application.ConvertFormula("=R[-1]C<>RC", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(1, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(196, 189, 151)
            fc.Borders(xlTop).LineStyle = xlDash
            
            ' CF for Last Ring
            cfForm = Application.ConvertFormula("=R[-1]C<>RC", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(2, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(196, 189, 151)
            
            ' CF for First ATN IP Loopback
            cfForm = Application.ConvertFormula("=R[-1]C[1]<>RC[1]", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(1, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(217, 217, 217)
            fc.Borders(xlTop).LineStyle = xlDash
                        
            ' CF for Last ATN IP Loopback
            cfForm = Application.ConvertFormula("=R[-1]C[1]<>RC[1]", xlR1C1, xlA1, xlRelRowAbsColumn, dtaRange.Cells(2, 1))
            Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:=cfForm)
            fc.Interior.Color = RGB(217, 217, 217)
            
        End With
    End With
End Sub
 

RickXL

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,316
No problem - I like a good puzzle. :)

Say "Hi!" to the team for me.

Regards,
 

Watch MrExcel Video

Forum statistics

Threads
1,118,853
Messages
5,574,670
Members
412,610
Latest member
bluedusty
Top