Results 1 to 4 of 4

Help with Macro (now to sort by dates)

Threaded View

  1. #1
    Registered User
    Join Date
    12-17-2012
    Location
    Wolverhampton,England
    MS-Off Ver
    Excel 2007
    Posts
    15

    Help with Macro (now to sort by dates)

     
    Sub HANSKEEBELLAH()
    If Selection.Columns.Count > 1 Then GoTo noGo
    If GetColumn(Selection.Column) <> "KZ" Then GoTo noGo
    
    Dim xRow    As Long
    Dim strtRow As Long
    Dim lstRow  As Long
    Dim myArray()
    Dim xCol    As Long
    Dim sCol    As Long
    Dim eCol    As Long
    Dim x       As Long
    Dim y       As Long
    Dim current As Worksheet
    Dim wsT     As Worksheet
    
    strtRow = Selection.Rows(1).Row
    lstRow = Selection.Rows(Selection.Rows.Count).Row
    
    Set current = Sheets(ActiveSheet.Name)
    
    Select Case MsgBox("Selection:" & vbNewLine & _
        Chr(9) & "# of rows selected" & Chr(9) & ": " & (lstRow - strtRow) + 1 & vbNewLine & _
        Chr(9) & "range to sort" & Chr(9) & ": 'LB" & strtRow & ":MT" & lstRow & "'" & vbNewLine & vbNewLine & _
        "Press 'OK' to continue", vbInformation + vbOKCancel, "")
    Case Is <> vbOK: Exit Sub
    End Select
    
    Application.ScreenUpdating = False
    ActiveWorkbook.Worksheets.Add Before:=current           ' create a temporary worksheet
    ActiveSheet.Name = "TEMP"
    Set wsT = Sheets("TEMP")
    Application.ScreenUpdating = True
    current.Activate
    
    For xRow = strtRow To lstRow
        If Len(Trim(Cells(xRow, "KZ").Value)) > 0 And Len(Trim(Cells(xRow, "LA").Value)) > 0 And _
            IsNumeric(Cells(xRow, "LA").Value) And Cells(xRow, "LA").Value > 0 And Len(Trim(Cells(xRow, "LB").Value)) > 0 Then
            Application.StatusBar = "Processing " & xRow & " row " & (xRow - strtRow) + 1 & " of " & (lstRow - strtRow) + 1
            x = 0
            wsT.Cells.Clear
            sCol = Cells(xRow, "KZ").Offset(0, 2).Column
            For xCol = sCol To sCol + 42 Step 3                 ' transpose the 5 column groups to the temporary worksheet
                x = x + 1
                With wsT
                    .Cells(x, 1).Value = Cells(xRow, GetColumn(xCol)).Value
                    .Cells(x, 2).Value = Cells(xRow, GetColumn(xCol + 1)).Value
                    .Cells(x, 3).Value = Cells(xRow, GetColumn(xCol + 2)).Value
                    .Cells(x, 4).Value = xRow
                    .Cells(x, 5).Value = InteriorColor(Cells(xRow, GetColumn(xCol)))
                End With
            Next xCol
            
            wsT.Sort.SortFields.Clear                           ' sort on column A with is the numeric value
            wsT.Sort.SortFields.Add Key:=Range("A1:A5"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With wsT.Sort
                .SetRange Range("A1:C15")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            x = 0
            For xCol = sCol To sCol + 42 Step 3                 ' transpose the sorted rows from the temporary sheet overwriting the original values
                x = x + 1
                Cells(xRow, GetColumn(xCol)).Value = wsT.Cells(x, 1).Value
                Cells(xRow, GetColumn(xCol + 1)).Value = wsT.Cells(x, 2).Value
                Cells(xRow, GetColumn(xCol + 2)).Value = wsT.Cells(x, 3).Value
                Range(GetColumn(xCol) & xRow & ":" & GetColumn(xCol + 2) & xRow).Interior.Color = wsT.Cells(x, 5).Value
            Next xCol
        End If
    Next xRow
    
    Application.StatusBar = False
    Application.DisplayAlerts = False
    wsT.Delete                                                      ' delete the temporary sheet
    Application.DisplayAlerts = True
    Cells(strtRow, "KZ").Select
    Exit Sub
    
    noGo:
    MsgBox "Incorrect column(s) selected!", vbExclamation, ""
    
    End Sub
    This sorts the data by using the 1st cell,4th cell,etc to the end of the row.
    now I wish it to sort by the 3rd cell,6th cell etc
    see excel sheet
    Thanks
    Steve.
    Last edited by pennbowl; 12-04-2014 at 04:39 PM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Macro To Sort Columns Only Works on One Tab
    By KimC in forum Excel General
    Replies: 17
    Last Post: 09-19-2014, 07:16 PM
  2. Macro works great in 2007 but not in older excel format
    By Tom R. in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 04-18-2013, 05:52 AM
  3. Replies: 3
    Last Post: 05-07-2012, 05:52 AM
  4. VBA Macro checks for duplicates,works great, but wish to add a select row
    By Mesjoggah in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 12-30-2011, 01:28 PM
  5. sort macro that works after leaving worksheet
    By garyablett in forum Excel General
    Replies: 1
    Last Post: 05-05-2006, 02:07 AM

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1