Rearranging the Data based on condition

N

Negi1984

Board Regular
Joined
May 6, 2011
Messages
198
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
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
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.
 
Upvote 0
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 ?
RickXL said:
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.
Click to expand...
Regards,Rajender
 
Upvote 0
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
 
Upvote 0
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
RickXL said:
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
Click to expand...
 
Upvote 0
No problem - I like a good puzzle. :)

Say "Hi!" to the team for me.

Regards,
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Rearranging rows based on sales and text
2
Replies
15
Views
645
SomeGuyHere
S
R
  • Solved
Move and Rearrange Data based on Header
2
Replies
19
Views
943
ruinedelf
R
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
133
kizzie37
K
D
  • Question
Grouped row visibility based on the condition of main row
Replies
0
Views
259
Dhruvil
D
M
  • Solved
Offset select upwards without looping without selecting hidden cells?
2
Replies
11
Views
447
MichaelRSnow
M

Forum statistics

Threads
1,214,667
Messages
6,120,808
Members
448,990
Latest member
rohitsomani

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