Excel copy/sort data while counting/removing duplicates

Question

Ok so I've searched and searched and can't quite find what I'm looking for.

I have a workbook and what I'm basically trying to do is take the entries from certain ranges (Sheet1 - E4:E12, E14:E20, I4:I7, I9:I12, I14:I17, & I19:I21) and put them in a separate list on Sheet2. I then want the new list on Sheet2 to be sorted by how many times an entry appeared on Sheet1 as well as display the amount.

example http://demonik.doomdns.com/images/excel.png

Obviously as can be seen by the ranges I listed above, this sample is much smaller lol, was just having trouble trying to figure out how to describe everything and figured an image would help.

Basically I am trying to use VBA (the update would be initialized by hitting a button) to copy data from Sheet1 and put all the ranges into one list in Sheet2 that is sorted by how many times it appeared on Sheet1, and then alphabetically.

If a better discription is needed just comment and let me know, I've always been horrible at trying to describe stuff like this lol.

Thanks in advance!

Another detail: I cant have it search for specific things as the data in the ranges on Sheet1 may change. Everything must be dynamic.

Answer 1

I started out with this data

and used the following code to read it into an array, sort the array, and count the duplicate values, then output the result to sheet2

Sub Example()
    Dim vCell As Range
    Dim vRng() As Variant
    Dim i As Integer

    ReDim vRng(0 To 0) As Variant

    Sheets("Sheet2").Cells.Delete
    Sheets("Sheet1").Select

    For Each vCell In ActiveSheet.UsedRange
        If vCell.Value <> "" Then
            ReDim Preserve vRng(0 To i) As Variant
            vRng(i) = vCell.Value
            i = i + 1
        End If
    Next

    vRng = CountDuplicates(vRng)

    Sheets("Sheet2").Select
    Range(Cells(1, 1), Cells(UBound(vRng), UBound(vRng, 2))) = vRng
    Rows(1).Insert
    Range("A1:B1") = Array("Entry", "Times Entered")
    ActiveSheet.UsedRange.Sort Range("B1"), xlDescending
End Sub

Function CountDuplicates(List() As Variant) As Variant()
    Dim CurVal As String
    Dim NxtVal As String
    Dim DupCnt As Integer
    Dim Result() As Variant
    Dim i As Integer
    Dim x As Integer
    ReDim Result(1 To 2, 0 To 0) As Variant

    List = SortAZ(List)

    For i = 0 To UBound(List)
        CurVal = List(i)

        If i = UBound(List) Then
            NxtVal = ""
        Else
            NxtVal = List(i + 1)
        End If

        If CurVal = NxtVal Then
            DupCnt = DupCnt + 1
        Else
            DupCnt = DupCnt + 1
            ReDim Preserve Result(1 To 2, 0 To x) As Variant

            Result(1, x) = CurVal
            Result(2, x) = DupCnt

            x = x + 1
            DupCnt = 0
        End If
    Next
    Result = WorksheetFunction.Transpose(Result)
    CountDuplicates = Result
End Function

Function SortAZ(MyArray() As Variant) As Variant()
    Dim First As Integer
    Dim Last As Integer
    Dim i As Integer
    Dim x As Integer
    Dim Temp As String

    First = LBound(MyArray)
    Last = UBound(MyArray)

    For i = First To Last - 1
        For x = i + 1 To Last
            If MyArray(i) > MyArray(x) Then
                Temp = MyArray(x)
                MyArray(x) = MyArray(i)
                MyArray(i) = Temp
            End If
        Next
    Next

    SortAZ = MyArray
End Function

End Result:

Answer 2

Here is a possible solution that I have started for you. What you are asking to be done gets rather complicated. Here is what I have so far: Option Explicit

Sub test()
    Dim items() As String
    Dim itemCount() As String
    Dim currCell As Range
    Dim currString As String
    Dim inArr As Boolean
    Dim arrLength As Integer
    Dim iterator As Integer
    Dim x As Integer
    Dim fullRange As Range
    Set fullRange = Range("E1:E15")
    iterator = 0

    For Each cell In fullRange 'cycle through the range that has the values
        inArr = False
        For Each currString In items 'cycle through all values in array, if
        'values is found in array, then inArr is set to true
            If currCell.Value = currString Then 'if the value in the cell we
            'are currently checking is in the array, then set inArr to true
                inArr = True
            End If
        Next
        If inArr = False Then 'if we did not find the value in the array
            arrLength = arrLength + 1
            ReDim Preserve items(arrLength) 'resize the array to fit the new values
            items(iterator) = currCell.Value 'add the value to the array
            iterator = iterator + 1
        End If
    Next
    'This where it gets tricky. Now that you have all unique values in the array,
    'you will need to count how many times each value is in the range.
    'You can either make another array to hold those values or you can
    'put those counts on the sheet somewhere to store them and access them later.
    'This is tough stuff! It is not easy what you need to be done.
    For x = 1 To UBound(items)

    Next

End Sub

All that this does so far is get unique values into the array so that you can count how many times each one is in the range.