We help IT Professionals succeed at work.

Excel 2003 - VBA sorting

TigerMan
TigerMan asked
on
Hi,
I have an array QikViewArr(1 To UBound(TmpArr, 1), 1 To 4).  The data in QikViewArr is already programatically populated.

QikViewArr is dumped to a worksheet as per
    Worksheets("QikViewSheet").Select
    Range("A3").CurrentRegion.ClearContents
    Range("A3:D" & 3 + UBound(QikViewArr, 1) - 1) = QikViewArr

The Column headings on QikViewSheet are in Row 3 i.e. A3, B3, C3, and D3.  Those values are programatically formatted to appear like hyperlinks i.e.
    Range("A3:D3").Select
    With Selection
        .Font.Bold = True
        .Font.ColorIndex = 5 ' blue
        .Font.Underline = xlUnderlineStyleSingle
    End With

I wish the user to CLICK on the Column Headings (in Row 3) and have the data on the sheet programmatically sorted in Descending order by THAT COLUMN.

Sound structured code with meaningful variable names only please ...
Comment
Watch Question

Care to upload a file?

Author

Commented:
OK, so no-one wanted it ... below is functional.  Are there any problems with this?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
   On Error Resume Next
   Dim SortRange, myTarget
   Set myTarget = Intersect(Target.Cells(1, 1), Range("A3:D3"))
   If myTarget Is Nothing Then Exit Sub
   SortRange = Range("A3").CurrentRegion
   Selection.Sort Key1:=myTarget, Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

End Sub

Author

Commented:
I left a play variable in there ... this works.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
   Dim myTarget
   
   On Error Resume Next
   Set myTarget = Intersect(Target.Cells(1, 1), Range("A3:D3"))
   If myTarget Is Nothing Then Exit Sub
   Selection.Sort Key1:=myTarget, Order1:=xlDescending, Header:=xlYes
   
End Sub

Author

Commented:
OK, so I have answered my own question.  In doing so I have found another question, and it may as well stay here because it is part of the same question.

How do I get this code to run on QikViewSheet which is created on the fly with VBA?  It is easy to paste into a Worksheet SelectionChange module in the code window, but how to do this programatically?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
   Dim myTarget
   
   On Error Resume Next
   Set myTarget = Intersect(Target.Cells(1, 1), Range("A3:D3"))
   If Not myTarget Is Nothing Then
      Range("A3:D3").Interior.ColorIndex = xlNone
      Selection.Interior.ColorIndex = 39
      Selection.Sort Key1:=myTarget, Order1:=xlDescending, Header:=xlYes
   Else
      Exit Sub
   End If
   
End Sub
Try something like this in the workbook module

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

   Dim myTarget

   If sh.name="QlkViewSheet" then

   On Error Resume Next
   Set myTarget = Intersect(Target.Cells(1, 1), Range("A3:D3"))
   If Not myTarget Is Nothing Then
      Range("A3:D3").Interior.ColorIndex = xlNone
      Selection.Interior.ColorIndex = 39
      Selection.Sort Key1:=myTarget, Order1:=xlDescending, Header:=xlYes
   Else
      Exit Sub
   End If

   End If

End Sub

Author

Commented:
Works nicely thanks ... I might leave this open for 24 hours coz i will be implementing this at work tomorrow and may have more 'dumb' questions :)

Author

Commented:
OK, so the process of constructing QikViewSheet sends many calls to the Workbook_ module above - this must have effect on speed etc.
I am not very good at working with sheet ranges without selecting them ... are any of the below able to be completed without the Select statements?

Sub FillAndFormatQikViewsheet(OneFoR)

    ' clear and copy QikViewArr to worksheet starting at row 4
    Worksheets("QikViewSheet").Select
    ActiveWindow.FreezePanes = False
    Cells.Delete    ' to empty all cells because the sheet may already exist and just need
                    ' correct data
    Range("A4:D" & 4 + UBound(QikViewArr, 1) - 1) = QikViewArr
    
    ' set up column headings and format sheet
    Range("A3").Value = "Year"
    Range("B3").Value = "Harvard"
    Range("C3").Value = "Total Cites"
    Range("D3").Value = "Cites per Year"
    Range("A3:D3").Select
    With Selection          ' make headings look like hyperlinks
        .Font.Bold = True
        .Font.ColorIndex = 5 ' blue
        .Font.Underline = xlUnderlineStyleSingle
    End With
    
    ' sundry formatting
    Columns("B:B").Select
    Selection.ColumnWidth = 79
    Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
    End With
    With Selection
        .WrapText = True
    End With
    Range("A:A,C:C,D:D").EntireColumn.AutoFit
    
    Range("D1").Select
    With Selection
        .HorizontalAlignment = xlRight
        .WrapText = False
    End With
    
    With Selection.Font
        .Bold = True
        .Name = "Arial"
        .Size = 10
    End With
    Rows("1:1").EntireRow.AutoFit
    
    Range("A3").CurrentRegion.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    ' borders around all cells with content
    For Counter = xlEdgeLeft To xlInsideHorizontal 'values 7 to 12
    With Selection.Borders(Counter)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Next Counter
 
    ' add a button to softly delete QikViewsheet
    With Cells(1, "A")
        Set aBtn = ActiveSheet.Buttons.Add(.Left, .Top, 35, 24)
        With aBtn
            .Caption = "Back to Main"
            .Font.Size = 8
            .OnAction = "DeleteQikViewSheet"
        End With
    End With
    Range("B1").Select
    Caption = "Analysing " & Format(MainFoR, "0000") & ": "
    Caption = Caption & "List of all articles that are coded in both "
    Caption = Caption & Format(MainFoR, "0000") & " and " & Format(OneFoR, "0000")
    Range("D1").Value = Caption
    
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    
    QikViewSheetFormatted = True ' enables the Workbook module to correctly control

End Sub

Open in new window

Author

Commented:
I have played with this and cleaned out most of the .select statements.  There are two statements left that I do not know how to deal with ... are you able to give code to process as desired, but with no .Select ?



    ' remove any borders (if the sheet exists and has been previously formatted)
    Range("A3").CurrentRegion.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   
    ' borders around all cells with content
    For Counter = xlEdgeLeft To xlInsideHorizontal 'values 7 to 12
    With Selection.Borders(Counter)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Next Counter
I have stripped the redundant selects without testing. See if it works.
Sub FillAndFormatQikViewsheet(OneFoR)

    ' clear and copy QikViewArr to worksheet starting at row 4
    Worksheets("QikViewSheet").Select
    ActiveWindow.FreezePanes = False
    Cells.Delete    ' to empty all cells because the sheet may already exist and just need
                    ' correct data
    Range("A4:D" & 4 + UBound(QikViewArr, 1) - 1) = QikViewArr
    
    ' set up column headings and format sheet
    Range("A3").Value = "Year"
    Range("B3").Value = "Harvard"
    Range("C3").Value = "Total Cites"
    Range("D3").Value = "Cites per Year"
    With Range("A3:D3")          ' make headings look like hyperlinks
        .Font.Bold = True
        .Font.ColorIndex = 5 ' blue
        .Font.Underline = xlUnderlineStyleSingle
    End With
    
    ' sundry formatting
    Columns("B:B").ColumnWidth = 79
    
    With Cells.Font
        .Name = "Arial"
        .Size = 8
        .WrapText = True
    End With
    Range("A:A,C:C,D:D").EntireColumn.AutoFit
    
    
    With Range("D1")
        .HorizontalAlignment = xlRight
        .WrapText = False
        .Bold = True
        .Name = "Arial"
        .Size = 10
    End With
    Rows("1:1").EntireRow.AutoFit
    

    Range("A3").CurrentRegion.Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A3").CurrentRegion.Borders(xlDiagonalUp).LineStyle = xlNone
    
    ' borders around all cells with content
    For Counter = xlEdgeLeft To xlInsideHorizontal 'values 7 to 12
    With Selection.Borders(Counter)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Next Counter
 
    ' add a button to softly delete QikViewsheet
    With Cells(1, "A")
        Set aBtn = ActiveSheet.Buttons.Add(.Left, .Top, 35, 24)
        With aBtn
            .Caption = "Back to Main"
            .Font.Size = 8
            .OnAction = "DeleteQikViewSheet"
        End With
    End With
    Caption = "Analysing " & Format(MainFoR, "0000") & ": "
    Caption = Caption & "List of all articles that are coded in both "
    Caption = Caption & Format(MainFoR, "0000") & " and " & Format(OneFoR, "0000")
    Range("D1").Value = Caption
    
    ActiveWindow.FreezePanes = True
    
    QikViewSheetFormatted = True ' enables the Workbook module to correctly control

End Sub

Open in new window

Author

Commented:
This works except the one area I identified above ... in "    With Selection.Borders(Counter)" there is nothing selected ...

    Range("A3").CurrentRegion.Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A3").CurrentRegion.Borders(xlDiagonalUp).LineStyle = xlNone
   
    ' borders around all cells with content
    For Counter = xlEdgeLeft To xlInsideHorizontal 'values 7 to 12
    With Selection.Borders(Counter)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Next Counter
Sorry I missed that. Try

with Range("A3").CurrentRegion.borders(counter)

Author

Commented:
agh yes ... stupid me ...
thanks and that is all
I will finalise the question shortly so thanks for your help ::)