Add sorting and adjacent selected cells

I had this question after viewing Module code needed to produce counts in new tab.  The code below works perfectly, but I would like to expand it so that it will sort with the highest count items on top.

I also want to be able to select more than one column to show next to the totals that should remain calculated only based on the first column selected.

As an example, I might select two adjacent columns and I would want that data (provided that the adjacent cells are just duplicate data on all like item numbers), to appear in columns C and D of the new tab next to the item count.

Sub CountItems()
Dim ws As Worksheet
Dim ColRng As Range
Dim Col As Integer
Dim lr As Long, i As Long
Dim x, dict

On Error Resume Next
Set ColRng = Application.InputBox("Please select a column to count items.", "Select Column!", Type:=8)
On Error GoTo 0

If ColRng Is Nothing Then
    MsgBox "You didn't select any column.", vbExclamation, "Column Not Selected!"
    Exit Sub
End If

Col = ColRng.Column
lr = Cells(Rows.Count, Col).End(xlUp).Row
x = Range(Cells(1, Col), Cells(lr, Col)).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    If Not dict.exists(x(i, 1)) Then
        dict.Item(x(i, 1)) = 1
    Else
        dict.Item(x(i, 1)) = dict.Item(x(i, 1)) + 1
    End If
Next i

On Error Resume Next
Set ws = Sheets("Count")
ws.Cells.Clear
On Error GoTo 0

If ws Is Nothing Then
    Set ws = Sheets.Add
    ws.Name = "Count"
End If
ws.Range("A1:B1").Value = Array("Item", "Count")
ws.Range("A2").Resize(dict.Count).Value = Application.Transpose(dict.keys)
ws.Range("B2").Resize(dict.Count).Value = Application.Transpose(dict.Items)
ws.Range("A1").CurrentRegion.Sort key1:=ws.Range("A2"), order1:=xlAscending, Header:=xlYes
End Sub

Select allOpen in new window