Extract unique values and their count from a two dimensional Array

I want a button that can be deployed on any Excel Worksheet. It does the following:
It checks column A..B, AA... AZ... until it finds a column that has only empty cells.
In each column, the macro program will find each filled-cell and add them to the end of a particular column (say the column to the right of the button).
After this operation, there will be one column with a lot of cells (that have text data).
The the macro program produce one simple report, showing:
1. How many unique value there are
2. How many records there are for each unique value.
Those two report can be to the right of the 'data column'.

Example:
Col A Col B Col C
gold wood porcelain
silver gold silver
gold fire
bronze melon
apple

then create a button. If you click on that button and it give you

gold 3
silver 2
bronze 1
apple 1
wood 1
fire 1
melon 1
porcelain 1

Then the job is done.

I am sorry I cannot upload the workbook. It contain confidential info of my client. Yes, I am trying to create a report with all the unique identifiers to a new worksheet. The example is given in the post. the count of columns and rows can vary. So I need macro that checks from first cell (may be A2) to last cell (may be AG5000).

I found this macro
Sub CollateExtractUniqueIDs()

Dim lColumns As Long: lColumns = Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1).Column
Dim lNextRow As Long: lNextRow = 2
Dim lLastRow As Long
lColumns = lColumns + 1
Application.ScreenUpdating = False
For i = 1 To lColumns
lLastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(1, i), Cells(lLastRow, i)).Copy _
Cells(lNextRow, lColumns + 1)
lNextRow = lNextRow + (lLastRow)
Next 'i
Application.ScreenUpdating = True
Application.ScreenUpdating = False

Cells(1, lColumns + 1).Value = "Combined"
Range(Cells(1, lColumns + 1), Cells(lNextRow - 1, lColumns + 1)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cells(1, lColumns + 2), _
Unique:=True
Cells(1, lColumns + 2).Value = "Unique"
Application.ScreenUpdating = True
End Sub

But, it will only list the unique values. I need the count of each value in next column
Please help. This is very urgent.

Thank you for posting that code Abousetta
I made some changes to my own previous code

Sub CollateExtractUniqueIDs()

Dim lColumns As Long: lColumns = Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1).Column
Dim lNextRow As Long: lNextRow = 2
Dim lLastRow As Long
lColumns = lColumns + 1
Application.ScreenUpdating = False
For i = 1 To lColumns
lLastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(1, i), Cells(lLastRow, i)).Copy _
Cells(lNextRow, lColumns + 1)
lNextRow = lNextRow + (lLastRow)
Next 'i
Application.ScreenUpdating = True
Application.ScreenUpdating = False

Cells(1, lColumns + 1).Value = "Combined"
Range(Cells(2, lColumns + 1), Cells(lNextRow - 1, lColumns + 1)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cells(1, lColumns + 2), _
Unique:=True
Cells(1, lColumns + 2).Value = "Unique"

lLastRow = Cells(Rows.Count, lColumns + 2).End(xlUp).Row
For i = 2 To lLastRow
Cells(i, lColumns + 3).Value = Application.WorksheetFunction.CountIf(Range(Cells(2, lColumns + 1), Cells(lNextRow - 1, lColumns + 1)), Cells(i, lColumns + 2))
Next i
Application.ScreenUpdating = True
End Sub

But the counts are not sorted. I need to sort the values in last column (lColumns + 3) and second last column (lColumns + 2) based on the values in last (lColumns + 3) in descending order. Could you please help me with this.
Thank you.

Thank you for all your help. I have changed your code a little bit to get my exact solution.
I am pasting the code and a sample done.

Code;


Sub ExtractAndCountUnique()

Dim lColumns As Long: lColumns = Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1).Column
Dim lNextRow As Long: lNextRow = 2
Dim lLastRow As Long
lColumns = lColumns + 1
Application.ScreenUpdating = False
For i = 1 To lColumns
lLastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(1, i), Cells(lLastRow, i)).Copy _
Cells(lNextRow, lColumns + 1)
lNextRow = lNextRow + (lLastRow)
Next 'i
Application.ScreenUpdating = True
Application.ScreenUpdating = False

Cells(1, lColumns + 1).Value = "Combined"
Range(Cells(2, lColumns + 1), Cells(lNextRow - 1, lColumns + 1)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cells(1, lColumns + 2), _
Unique:=True
Cells(1, lColumns + 2).Value = "Unique"

lLastRow = Cells(Rows.Count, lColumns + 2).End(xlUp).Row
For i = 2 To lLastRow
Cells(i, lColumns + 3).Value = Application.WorksheetFunction.CountIf(Range(Cells(2, lColumns + 1), Cells(lNextRow - 1, lColumns + 1)), Cells(i, lColumns + 2))
Next i

ActiveSheet.Range(Cells(1, lColumns + 2), Cells(lLastRow, lColumns + 3)).Select
Selection.Sort Key1:=Range(Cells(1, lColumns + 3), Cells(lLastRow, lColumns + 3)), Order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Cells(1, lColumns + 3).Value = "Count"
End Sub


Sample:
a b c d e a
f g h i j f
k l m n o k
p q r s t p
u v w x y u
z a s a s z
a a a s s s

Solution:

Combined Unique Count
a a 7
f s 6
k f 2
p k 2
u p 2
z u 2
a z 2
b b 1
g g 1
l l 1
q q 1
v v 1
a c 1
a h 1
c m 1
h r 1
m w 1
r d 1
w i 1
s n 1
a x 1
d e 1
i j 1
n o 1
s t 1
x y 1
a
s
e
j
o
t
y
s
s
a
f
k
p
u
z
s