Shifting Cells Right on IsDate

[Griffin77]

Hi, Need some help on a spreadsheet that I frequently work on.

After a number of tries I have reached the end of my excel and macro knowledge (newbie).

The excel sheet only has one sheet(tab), in the first column of the sheet there are people's names or dates. In the fourth column are people's names again.

What I need to do is, if the value of each cell in column A is a name, leave it alone. If the value of the cell in column A is a date, shift the entire row to the right one cell.

Once this is done, i need to sort the rows under each name alphabetically between the empty cells. This can be done by first name since the first and last names are both in the same cell.

Sheet Example:

A B C D
Mike
9/28/11 item 1 code123 John Doe
9/28/11 item 2 code456 Jane Doe
9/27/11 item 1 code123 Mickey Mouse
Eric
9/28/11 item 1 code123 George Washington
9/28/11 item 2 code456 Abraham Lincoln
9/27/11 item 1 code123 John F Kennedy

Desired Results:

A B C D E
Mike
9/28/11 item 2 code456 Jane Doe
9/28/11 item 1 code123 John Doe
9/27/11 item 1 code123 Mickey Mouse
Eric
9/28/11 item 2 code456 Abraham Lincoln
9/28/11 item 1 code123 George Washington
9/27/11 item 1 code123 John F Kennedy

 

[Joe4]

Welcome to the Board! This code seems to do this trick:

Sub MyMacro()
 
    Dim myLastRow As Long
    Dim myFirstSortRow As Long
    Dim myLastSortRow As Long
    Dim mySortColumn As String
    Dim mySortRange As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    
'   Find last row
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows
    For i = 1 To myLastRow + 1
        If IsDate(Cells(i, "A")) Then
'   Insert column & set counters
            Cells(i, "A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            If myFirstSortRow = 0 Then myFirstSortRow = i
            myLastSortRow = i
        Else
'   New person, so first sort previous area...
            If myFirstSortRow > 0 Then
                mySortColumn = "E" & myFirstSortRow & ":E" & myLastSortRow
                mySortRange = "B" & myFirstSortRow & ":E" & myLastSortRow
                ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
                ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(mySortColumn), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With ActiveWorkbook.ActiveSheet.Sort
                    .SetRange Range(mySortRange)
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            End If
'   Reset counters
            myFirstSortRow = 0
            myLastSortRow = 0
        End If
    Next i
    
    Application.ScreenUpdating = True
         
End Sub

Note, if your data begins on some row other than the first one, update the "For" loop statement to reflect that (For i = ...)

 

[John_w]

Thought I'd post my code, which coincidentally is almost identical to Joe4's, shifting and sorting in a single pass through the rows.

Griffin77, you might want to run the code on a copy of your workbook.

Sub Shift_Rows_and_Sort()

    Dim lastRow As Long, row As Long, firstSortRow As Long, lastSortRow As Long
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).row
    firstSortRow = 0
    
    For row = 1 To lastRow + 1
        If IsDate(Cells(row, "A").Value) Then
            
            'Shift date cell to the right by 1 cell
            
            Cells(row, "A").Insert Shift:=xlToRight
            If firstSortRow = 0 Then firstSortRow = row
            lastSortRow = row
            
        ElseIf firstSortRow > 0 Then
                
            'New person, so sort previous block of rows on column E (first and last names)
            
            Rows(firstSortRow & ":" & lastSortRow).Sort Key1:=Cells(firstSortRow, "E"), Order1:=xlAscending, Header:=xlGuess, _
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
            
            firstSortRow = 0
            
        End If
    Next
    
End Sub

 

[Griffin77]

Gentlemen,

THANK YOU SOOO MUCH!

You scripts rocked and fixed my issue!!!