Sorting Question

  • Thread starter Thread starter Craig
  • Start date Start date
C

Craig

Is there a way to write a macro that can sort a list alphabetically
with the first new letter of each group having a higher row?

Aaaaa bbbbbb ccc dddd

First A having a 26.25 point row height and the rest having 12.75
point row height
First B having a 26.25 point row height and the rest having 12.75
point row height.
First C having a 26.25 point row height and the rest having 12.75
point row height
First D having a 26.25 point row height and the rest having 12.75
point row height
With the amount of letters in each group varying day to day
 
You would do your sort first, then loop through the range to change row
height.

Sub test()
Dim LastRow As Long
Dim c As Range, MyRng As Range
Dim a As String, b As String

LastRow = Cells(Rows.Count, "A").End(xlUp).Row 'change as needed
Set MyRng = Range("A1:A" & LastRow) 'change as needed

MyRng.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For Each c In MyRng
If c.Row = 1 Then 'do nothing
Else
If Left(c.Value, 1) = Left(c.Offset(-1, 0).Value, 1) Then
'do nothing
Else
c.RowHeight = 26.25
End If
End If
Next
End Sub

MIke F
 
Maybe something like this to sort and enter a UCase letter at each change in
alphabet.

Sub Alphabet_Sort()

Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Columns("A:A").Select
Selection.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

FirstRow = 2
LastRow = Cells(Rows.Count, "a").End(xlUp).Row

For iRow = LastRow To FirstRow Step -1
If Left(Cells(iRow, "a").Value, 1) <> _
Left(Cells(iRow - 1, "a").Value, 1) Then
Rows(iRow).Insert
With Cells(iRow, "a")
.Value = UCase(Left(Cells(iRow + 1, "a").Value, 1))
.Font.Bold = True
.Font.Size = 20
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Underline = xlUnderlineStyleSingle
End With
End If
Next
End Sub


Gord Dibben MS Excel MVP
 
Back
Top