VBA to sort data and extra line between departments

[Damo10]

Hi,

I have a sheet that I am creating that has department numbers in column C and names in column B what I would like to do is have a macro to sort the data in columns B:DL by department number then by name but after each department add an extra line in so that they are spaced out.

Can anyone help with this is I cant see a way of doing it with the normal sort?

Regards,

 

[Fluff]

How about

Sub SortAddBlankRows()

   Dim Cnt As Long
   
   With Worksheets("Size Breaks")
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=Columns(2), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      .Sort.SortFields.Add Key:=Columns(3), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
         .SetRange Worksheets("Size Breaks").UsedRange
         .header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With
      For Cnt = .Range("B" & Rows.Count).End(xlUp).Row To 3 Step -1
         If .Range("B" & Cnt).Value <> .Range("B" & Cnt - 1).Value Then
            Rows(Cnt).Insert
         End If
      Next Cnt
   End With
   
End Sub

 

[Damo10]

Hi,

Thanks for the reply it seems to work but can it only sort the data from row 8 and below?

Regards,

 

[Fluff]

How about

Sub SortAddBlankRows()

   Dim Cnt As Long
   Dim UsdRws As Long
   
   With Worksheets("Size Breaks")
      UsdRws = .Range("B" & Rows.Count).End(xlUp).Row
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=.Range("B8:B" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      .Sort.SortFields.Add Key:=.Range("C8:C" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
         .SetRange Worksheets("Size Breaks").Range("B8:DL" & UsdRws)
         .header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With
      For Cnt = .Range("B" & Rows.Count).End(xlUp).Row To 10 Step -1
         If .Range("B" & Cnt).Value <> .Range("B" & Cnt - 1).Value Then
            .Rows(Cnt).Insert
         End If
      Next Cnt
   End With
   
End Sub

 

[Damo10]

Hi,

I have tried this code and unfortunately it does not add a row under the first change of department but it does add a row even if there are more than one entry for a department and it does not sort them by department then by name only name.

Regards,

 

[Fluff]

Apologies I got it the wrong way round, try this

Sub SortAddBlankRows()

   Dim Cnt As Long
   Dim UsdRws As Long
   
   With Worksheets("Size Breaks")
      UsdRws = .Range("B" & Rows.Count).End(xlUp).Row
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=.Range("C8:C" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      .Sort.SortFields.Add Key:=.Range("B8:B" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
         .SetRange Worksheets("Size Breaks").Range("B8:DL" & UsdRws)
         .header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With
      For Cnt = .Range("C" & Rows.Count).End(xlUp).Row To 10 Step -1
         If .Range("C" & Cnt).Value <> .Range("C" & Cnt - 1).Value Then
            .Rows(Cnt).Insert
         End If
      Next Cnt
   End With
   
End Sub

 

[Damo10]

Hi,

That is better thanks, the only issue is that it is still does not add a row after the first department if there is only 1 entry for that department

Regards

 

[Fluff]

Do you have a header row in row 8?

 

[Damo10]

No, the headers are in row 7 and the data starts from row 8
It works ok if the first department when sorted has more than one entry but not if there is only one

Regards,

 

[Fluff]

Ok try this

Sub SortAddBlankRows()

   Dim Cnt As Long
   Dim UsdRws As Long
   
   With Worksheets("Size Breaks")
      UsdRws = .Range("B" & Rows.Count).End(xlUp).Row
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=.Range("C[COLOR=#ff0000]7[/COLOR]:C" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      .Sort.SortFields.Add Key:=.Range("B[COLOR=#ff0000]7[/COLOR]:B" & UsdRws), SortOn:=xlSortOnValues, _
         Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
         .SetRange Worksheets("Size Breaks").Range("B[COLOR=#ff0000]7[/COLOR]:DL" & UsdRws)
         .header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With
      For Cnt = .Range("C" & Rows.Count).End(xlUp).Row To [COLOR=#ff0000]9[/COLOR] Step -1
         If .Range("C" & Cnt).Value <> .Range("C" & Cnt - 1).Value Then
            .Rows(Cnt).Insert
         End If
      Next Cnt
   End With
   
End Sub

Changes in red(4 in total)