例如
國別
Wales
USA; USA; USA; USA; USA
USA; USA; Taiwan; USA
USA; USA; Italy; USA; USA
USA; Spain
USA; South Korea
Switzerland; Switzerland; Belgium; Italy; Belgium; Italy
則
國家 筆數
Wales 1
USA 5
Taiwan 1
Italy 2
Spain 1
South Korea 1
Switzerland 1
Belgium 1
例如
North Ireland; North Ireland
Ireland; Ireland
Ireland
Germany; Ireland
Canada; North Ireland; Peoples R China
結果
Ireland 5
North Ireland 2作者: GBKEE 時間: 2010-10-2 07:50
回復 7#偉婕
Function Word_Count(Word As String, WordRange As Range) As Integer
Dim i As Integer, E As Range, A
For Each E In WordRange
For Each A In Split(E, ";")
If Trim(A) = Trim(Word) Then i = i + 1: Exit For
Next
Next
Word_Count = i
End Function作者: Hsieh 時間: 2010-10-2 09:18
Option Explicit
Sub TEST()
Dim Brr, i&, S&, T, V, Y, Z
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([A2], Cells(Rows.Count, 1).End(3)): T = "; "
For i = 1 To UBound(Brr)
For Each V In Split(Brr(i, 1), T)
If InStr(Z, "/" & V & "/") = 0 And V <> "" Then
Z = Z & "/" & V & "/": Y(V) = Y(V) + 1: S = S + 1
End If
Next
Z = ""
Next
[J:K].ClearContents: [J1] = [A1]: [K1] = "國別數(每格不重複統計)"
[J2].Resize(Y.Count, 1) = Application.Transpose(Y.keys)
[K2].Resize(Y.Count, 1) = Application.Transpose(Y.items)
With [J2].Resize(Y.Count, 2)
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
.EntireColumn.AutoFit
End With
MsgBox S
Set Y = Nothing: Set Brr = Nothing
End Sub作者: Andy2483 時間: 2023-3-29 14:59
Option Explicit
Sub TEST_2()
Dim Brr, V, Y, i&, N&, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
N = Cells(Rows.Count, 1).End(3).Row
Set xR = Range([B1], Cells(N * 2, 1))
Brr = xR: Y(0) = N: Y(2) = "; "
For i = 2 To UBound(Brr) / 2
For Each V In Split(Brr(i, 1), Y(2))
If InStr(Y(3), "/" & V & "/") = 0 And V <> "" Then
Y(3) = Y(3) & "/" & V & "/": Y(1) = Y(1) + 1
If Y(V) = "" Then
Y(0) = Y(0) + 1: Y(V) = Y(0)
Brr(Y(0), 1) = V: Brr(Y(0), 2) = 1
Else
Brr(Y(V), 2) = Brr(Y(V), 2) + 1
End If
End If
Next
Y(3) = ""
Next
With [J1].Resize(UBound(Brr), 2)
.EntireColumn.ClearContents
.Value = Brr
Intersect(Rows("1:" & N), .Cells).ClearContents
.Item(1) = "國別": .Item(2) = "國別數(每格不重複統計)"
.Sort KEY1:=.Item(1), Order1:=1, Header:=1
.EntireColumn.AutoFit
End With
MsgBox Y(1)
Set Y = Nothing: Set Brr = Nothing: Set xR = Nothing
End Sub
=========================================
補充:
忘了考慮到國別數如果比原資料列多就會錯誤,2倍堪慮!此法不好
=========================================
Option Explicit
Sub TEST_3()
Dim Arr, Brr, V, Y, i&, N&, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B1], Cells(Rows.Count, 1).End(3))
Brr = xR: Y(2) = "; "
ReDim Arr(1 To 10000, 1 To 2)
For i = 2 To UBound(Brr)
For Each V In Split(Brr(i, 1), Y(2))
If InStr(Y(3), "/" & V & "/") = 0 And V <> "" Then
Y(3) = Y(3) & "/" & V & "/": Y(1) = Y(1) + 1
If Y(V) = "" Then
Y(0) = Y(0) + 1: Y(V) = Y(0)
Arr(Y(0), 1) = V: Arr(Y(0), 2) = 1
Else
Arr(Y(V), 2) = Arr(Y(V), 2) + 1
End If
End If
Next
Y(3) = ""
Next
With [J2].Resize(Y(0), 2)
.EntireColumn.ClearContents
.Value = Arr
.Item(0, 1) = "國別": .Item(0, 2) = "國別數(每格不重複統計)"
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
.EntireColumn.AutoFit
End With
MsgBox Y(1)
Set Y = Nothing: Set Brr = Nothing: Set xR = Nothing
End Sub
D),)))*1)-1) 為何要減1