Results 1 to 5 of 5
  1. #1
    3 Star Lounger
    Join Date
    Nov 2011
    Location
    Australia
    Posts
    221
    Thanks
    80
    Thanked 3 Times in 2 Posts

    Coverting rows to column in date and time order

    Excel 2003, for now.

    In Sheet 1 I have info. imported from a web page, another macro does some editing etc, no problems there.

    Another macro is required so it turns out the way it is in Sheet 2
    But also ending up in date and time order.

    It can go as far as 350 rows down in Sheet 1 with 1 or 2 (maximum) blank
    rows at various intervals.
    So I have only provided a portion, because doing this
    manually 250 rows plus, at times gets a bit tedious to say the least.

    Can someone help with a macro so the info. ends up looking like it does in
    Sheet 2, time and date order please

    Notice in Sheet 2, rows 43-47 I have hi-lited to show the time and date order can go to
    midnight and onto the next day's date.

    The time and date order obviously needs to be from the AM to PM



    Thanks in advance, much appreciated.
    Attached Files Attached Files

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,640
    Thanks
    115
    Thanked 651 Times in 593 Posts
    XP,

    This code will copy data to a sheet called Sorted in the format you specified, however, it will arrange the name groups alphabetically (Primary criteria) and then by date/time (Secondary Criteria). There is no limitations to the number of columns or rows so it will grow accordingly. The blank cells will be disregarded. There is 1 instance of Sheet1 and 6 instances of Sorted in the code that need to be changed to the names of the actual sheets used.

    HTH,
    Maud

    Code:
    Public Sub ReArrange()
    Worksheets("Sheet1").Activate
    Row = 3
    With Worksheets("Sorted")
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For I = 3 To LastRow
        Lastcol = ActiveSheet.Cells(I, Application.Columns.Count).End(xlToLeft).Column
        For J = 4 To Lastcol
            If Cells(I, J).Value = "" Then GoTo Done
            .Cells(Row, 1).Value = Cells(I, 1).Value
            .Cells(Row, 2).Value = Cells(I, 2).Value
            .Cells(Row, 3).Value = J - 3
            .Cells(Row, 4).Value = Cells(I, 3).Value
            .Cells(Row, 5).Value = Cells(I, J).Value
            Row = Row + 1
    Done:
        Next J
    Next I
    End With
    Worksheets("Sorted").Activate
        Range(Cells(3, 1), Cells(Row, 5)).Select
        ActiveWorkbook.Worksheets("Sorted").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sorted").Sort.SortFields.Add Key:=Range("D3:D57") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("Sorted").Sort.SortFields.Add Key:=Range("E3:E57") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sorted").Sort
            .SetRange Range(Cells(3, 1), Cells(Row, 5))
            .Header = xlNo
            .Apply
        End With
    Range("A1").Select
    
    End Sub
    Attached Files Attached Files
    Last edited by Maudibe; 2013-03-28 at 00:20.

  3. #3
    3 Star Lounger
    Join Date
    Nov 2011
    Location
    Australia
    Posts
    221
    Thanks
    80
    Thanked 3 Times in 2 Posts
    Maudibe,

    Thanks,

    Have added a bit extra code for "cosmetics".
    I can live with having to do the the "midnite to next day's date" Ascending Sort by cut and paste to bottom of list manually.
    Other than that it's a good as done for this part of a larger process.
    Attached Files Attached Files

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,640
    Thanks
    115
    Thanked 651 Times in 593 Posts
    XP,

    Looking at your initial upload (Sheet2), I had thought you wanted to group by name and then by date/time, not just by time. Apologies

  5. #5
    3 Star Lounger
    Join Date
    Nov 2011
    Location
    Australia
    Posts
    221
    Thanks
    80
    Thanked 3 Times in 2 Posts
    No Prob,

    I have added another piece of code, this helps if anyone is required to delete unspecified
    Rows with Loop, If, Then scenarios

    Code:
    Sub DeleteRow()
    
    Sheets("Sorted").Select
    Sheets("Sorted").Range("E3").Select
    Do Until ActiveCell.Value = ""
    
                'current cell          Or cell to Right ( will NOT keep )                   canceled appointments
    If ActiveCell.Value = "" Or ActiveCell.Offset(0, 1).Value = "" Or ActiveCell.Offset(0, 1).Value = "Cncld " Then
    
    'current cell          Or cell to Right ( will KEEP )                                  canceled appointments
    'If ActiveCell.Value = "" Or ActiveCell.Offset(0, -1).Value = "" Or ActiveCell.Offset(0, 1).Value = "Cncld " Then
    
    ActiveCell.EntireRow.Delete
    ActiveCell.Offset(-1, 0).Select
    End If
    ActiveCell.Offset(1, 0).Select
    Loop
    
    End Sub
    PS
    After posting, the long bits did not fit entirely on this forum, so it may look wrong due to
    word wrapping here, but it works in the VBA Module.
    Last edited by XPDiHard; 2013-03-28 at 21:48.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •