Sub
Counter(rngDataSource
As
Range, NameDestination
As
String
)
Dim
Counter()
As
Variant
Dim
rng
As
Range
Dim
rngNm
As
Range, rngNew
As
Range
Dim
Item
As
Variant
Dim
bHasData
As
Boolean
Dim
iPos
As
Integer
For
Each
rng
In
rngDataSource.Cells
For
Each
Item
In
Split(rng.Value,
" "
)
Item = Trim(Item)
If
Not
Right(Item, 1) =
":"
Then
CounterItem Counter, Item
bHasData =
True
End
If
Next
Next
SortArray Counter
Set
rngNm = ActiveWorkbook.Names(NameDestination).RefersToRange
rngNm.Clear
If
bHasData
Then
For
iPos = 0
To
UBound(Counter, 2)
rngNm(iPos + 1, 1) = Counter(0, iPos)
rngNm(iPos + 1, 2) = Counter(1, iPos)
Next
End
If
Set
rngNm = rngNm.Cells(1, 1)
Set
rngNew = Range(rngNm, rngNm.Offset(iPos - 1, 1))
rngNew.
Select
ActiveWorkbook.Names(NameDestination).Delete
ActiveWorkbook.Names.Add NameDestination, rngNew
End
Sub
Sub
CounterItem(
ByRef
data()
As
Variant
,
ByVal
search
As
String
)
On
Error
Resume
Next
Dim
iPos
As
Integer
Dim
hi
As
Integer
Dim
bFound
As
Boolean
hi = UBound(data, 2)
If
Not
Err.Number = 0
Then
Err.Clear
ReDim
data(1, 0)
data(0, 0) = search
data(1, 0) = 1
Else
bFound =
False
For
iPos = 0
To
UBound(data, 2)
If
data(0, iPos) = search
Then
data(1, iPos) = data(1, iPos) + 1
bFound =
True
Exit
For
End
If
Next
If
Not
bFound
Then
ReDim
Preserve
data(1, UBound(data, 2) + 1)
data(0, UBound(data, 2)) = search
data(1, UBound(data, 2)) = 1
End
If
End
If
End
Sub
Sub
SortArray(
ByRef
data()
As
Variant
)
On
Error
GoTo
Err_Handler
Dim
iPos
As
Integer
Dim
tmp(1)
As
Variant
iPos = 1
Do
If
data(0, iPos) < data(0, iPos - 1)
Then
tmp(0) = data(0, iPos)
tmp(1) = data(1, iPos)
data(0, iPos) = data(0, iPos - 1)
data(1, iPos) = data(1, iPos - 1)
data(0, iPos - 1) = tmp(0)
data(1, iPos - 1) = tmp(1)
If
iPos > 1
Then
iPos = iPos - 1
Else
iPos = iPos + 1
End
If
Loop
While
iPos <= UBound(data, 2)
Err_Exit:
Exit
Sub
Err_Handler:
Err.Clear
GoTo
Err_Exit
End
Sub