VBA Filter, separate names, add colour fill

tezza

tezza

Active Member
Joined
Sep 10, 2006
Messages
375
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
  2. Web
Hi All

Below is a before and after of what I need to achieve but need help to do it please:

NameVisitTypeVisit IdStart TimeEnd TimeStatusAssignee
VisitCare and Support169863012/Jun/2023 09:3012/Jun/2023 13:30OutstandingHomer
VisitCare and Support170187112/Jun/2023 10:0012/Jun/2023 17:00OutstandingLisa
VisitCare and Support169573312/Jun/2023 14:0012/Jun/2023 17:00OutstandingHomer
VisitCare and Support170422512/Jun/2023 17:3012/Jun/2023 18:30OutstandingHomer
VisitCare and Support170461413/Jun/2023 08:1013/Jun/2023 09:40OutstandingMarge
VisitCare and Support169731413/Jun/2023 09:1513/Jun/2023 10:15OutstandingHomer
VisitCare and Support170427213/Jun/2023 09:0013/Jun/2023 13:00OutstandingBart
VisitCare and Support170461013/Jun/2023 10:0013/Jun/2023 13:00OutstandingLisa
VisitCare and Support162791513/Jun/2023 10:0013/Jun/2023 14:00OutstandingMarge
VisitCare and Support170426713/Jun/2023 13:3013/Jun/2023 16:30OutstandingBart
VisitCare and Support170424114/Jun/2023 09:3014/Jun/2023 14:30OutstandingMarge
VisitCare and Support170461614/Jun/2023 14:4514/Jun/2023 15:45OutstandingMarge
VisitCare and Support170503814/Jun/2023 12:0014/Jun/2023 16:00OutstandingLisa


The list needs to group all the same names together. create a space between the names and show a colour separation. The list varies in length.

NameVisitTypeVisit IdStart TimeEnd TimeStatusAssignee
VisitCare and Support170427213/Jun/2023 09:0013/Jun/2023 13:00OutstandingBart
VisitCare and Support170426713/Jun/2023 13:3013/Jun/2023 16:30OutstandingBart
VisitCare and Support170187112/Jun/2023 10:0012/Jun/2023 17:00OutstandingLisa
VisitCare and Support170461013/Jun/2023 10:0013/Jun/2023 13:00OutstandingLisa
VisitCare and Support170503814/Jun/2023 12:0014/Jun/2023 16:00OutstandingLisa
VisitCare and Support169863012/Jun/2023 09:3012/Jun/2023 13:30OutstandingHomer
VisitCare and Support169573312/Jun/2023 14:0012/Jun/2023 17:00OutstandingHomer
VisitCare and Support170422512/Jun/2023 17:3012/Jun/2023 18:30OutstandingHomer
VisitCare and Support169731413/Jun/2023 09:1513/Jun/2023 10:15OutstandingHomer
VisitCare and Support170461413/Jun/2023 08:1013/Jun/2023 09:40OutstandingMarge
VisitCare and Support162791513/Jun/2023 10:0013/Jun/2023 14:00OutstandingMarge
VisitCare and Support170424114/Jun/2023 09:3014/Jun/2023 14:30OutstandingMarge
VisitCare and Support170461614/Jun/2023 14:4514/Jun/2023 15:45OutstandingMarge


Thank you
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
How will this do?

Code: 
Sub tezzaSPLIT()
Dim lr, i As Long
lr = Sheets("tezza1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("tezza1").Range("A1:G" & lr).Copy Worksheets("tezza2").Range("A1:G" & lr)
Sheets("tezza2").Sort.SortFields.Clear
Sheets("tezza2").Range("A1:G" & lr).Sort Key1:=Range("tezza2!G1"), Order1:=xlAscending
For i = lr To 3 Step -1
 If Cells(i, "G") <> Cells(i - 1, "G") Then
   Rows(i).EntireRow.Insert
   Rows(i).EntireRow.Insert
   Range("A" & i & ":G" & i).Interior.ColorIndex = 5 ' 5 indicates Blue Color
   Rows(i).EntireRow.Insert
 Else
 End If
Next i
End Sub
 
Upvote 0
This code will sort the data by columns G and C.

I dont know what your worksheet name is so I have used 'SplitNames'.

You will have to change this on this line.
Set WsSource = Worksheets("SplitNames")

My code keeps the source data as it is, always a good idea, and copies the data to another sheet called 'SplitNamesResult'.

You can change this if you like on this line.
Set WsDest = Worksheets("SplitNamesResult")

Remember to create the worksheet 'SplitNamesResult' or whatever you want to call it, before you run the code.

VBA Code: 
Public Sub SplitNames()
Dim lngLastRow As Long
Dim arr() As Variant
Dim i As Integer
Dim ii As Integer
Dim lngRow As Long
Dim WsDest As Worksheet
Dim WsSource As Worksheet

    ActiveWorkbook.Save
    
    Set WsSource = Worksheets("SplitNames")
    
    WsSource.Activate
    
    Set WsDest = Worksheets("SplitNamesResult")
    
    WsDest.Cells.Clear

    With WsSource
    
        lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
       
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=.Range("G2:G" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=.Range("C2:C" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange ActiveSheet.Range("A1").CurrentRegion
            .Apply
        End With
        
        WsDest.Range("A1:G2").Value = .Range("A1:G2").Value
    
        arr = .Range("A2:G" & lngLastRow).Value
    
    End With
        
    lngRow = 2
                
    For i = 2 To UBound(arr)
        
        If arr(i, 7) <> arr(i - 1, 7) Then
                  
            WsDest.Range("A" & lngRow + 2 & ":G" & lngRow + 2).Interior.Color = RGB(191, 191, 191)
                 
            lngRow = lngRow + 4
                 
        Else
        
            lngRow = lngRow + 1
            
        End If
            
        For ii = LBound(arr, 2) To UBound(arr, 2)
            WsDest.Cells(lngRow, ii).Value = arr(i, ii)
        Next
            
    Next i
        
    WsDest.Activate

    With WsDest.UsedRange
        .Font.Name = "Arial"
        .Font.Size = 16
        .RowHeight = 26
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = vbBlack
        End With
    End With
                
End Sub
 
Upvote 0
Solution
Herakles said:
This code will sort the data by columns G and C.

I dont know what your worksheet name is so I have used 'SplitNames'.

You will have to change this on this line.
Set WsSource = Worksheets("SplitNames")

My code keeps the source data as it is, always a good idea, and copies the data to another sheet called 'SplitNamesResult'.

You can change this if you like on this line.
Set WsDest = Worksheets("SplitNamesResult")

Remember to create the worksheet 'SplitNamesResult' or whatever you want to call it, before you run the code.

VBA Code: 
Public Sub SplitNames()
Dim lngLastRow As Long
Dim arr() As Variant
Dim i As Integer
Dim ii As Integer
Dim lngRow As Long
Dim WsDest As Worksheet
Dim WsSource As Worksheet

    ActiveWorkbook.Save
   
    Set WsSource = Worksheets("SplitNames")
   
    WsSource.Activate
   
    Set WsDest = Worksheets("SplitNamesResult")
   
    WsDest.Cells.Clear

    With WsSource
   
        lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
      
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=.Range("G2:G" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=.Range("C2:C" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange ActiveSheet.Range("A1").CurrentRegion
            .Apply
        End With
       
        WsDest.Range("A1:G2").Value = .Range("A1:G2").Value
   
        arr = .Range("A2:G" & lngLastRow).Value
   
    End With
       
    lngRow = 2
               
    For i = 2 To UBound(arr)
       
        If arr(i, 7) <> arr(i - 1, 7) Then
                 
            WsDest.Range("A" & lngRow + 2 & ":G" & lngRow + 2).Interior.Color = RGB(191, 191, 191)
                
            lngRow = lngRow + 4
                
        Else
       
            lngRow = lngRow + 1
           
        End If
           
        For ii = LBound(arr, 2) To UBound(arr, 2)
            WsDest.Cells(lngRow, ii).Value = arr(i, ii)
        Next
           
    Next i
       
    WsDest.Activate

    With WsDest.UsedRange
        .Font.Name = "Arial"
        .Font.Size = 16
        .RowHeight = 26
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = vbBlack
        End With
    End With
               
End Sub
Click to expand...
Hi, That's perfect, thank you
 
Upvote 0
Another approach that you could consider. You didn't mention putting the results on another worksheet so this does it on the same sheet which I have assumed is the active sheet.
Test with a copy of your workbook.

VBA Code: 
Sub MakeGroups()
  Dim rB As Range
  
  Application.ScreenUpdating = False
  With Range("A1").CurrentRegion
    .Sort Key1:=.Columns(7), Order1:=xlAscending, Key2:=.Columns(3), Order2:=xlAscending, Header:=xlYes
    .Subtotal GroupBy:=7, Function:=xlCount, TotalList:=Array(4)
  End With
  For Each rB In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks)
    rB.Resize(3).EntireRow.Insert
    rB.Rows(-1).Resize(, 7).Interior.Color = RGB(191, 191, 191)
  Next rB
  ActiveSheet.UsedRange.RemoveSubtotal
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Formula Help.
Replies
3
Views
87
Fluff
Fluff
B
  • Solved
Group number of purchased SKUs by counting customer
2
Replies
16
Views
241
shaowu459
shaowu459
A
  • Solved
AVERAGEIFS with 4 criteria
2
Replies
16
Views
328
Fluff
Fluff
J
  • Solved
Add 1 day to a date within a range as long as 2 conditions are met [without macros]
Replies
4
Views
574
juanam
J
A
  • Question
I want to fill the matrix next to Hour Out with the headcount based on the data from the first 3 columns. Please help!! :'(
Replies
0
Views
65
AliaNi
A

Forum statistics

Threads
1,215,212
Messages
6,123,651
Members
449,111
Latest member
ghennedy

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