[發問] 請教國別筆數之計算

偉婕

我有上千筆資料,每一列算一筆資料
在A欄[國別]儲存格中,由一個或數個字串組成,中間以分號隔開
每個儲存格中之國家,不管出現的位置,或者是否重複,只要有出現僅計數1次

例如
國別
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

目前問題是解決了,不過覺得自己的方法不是很有效率,所以,想請教各位有沒有什麼較有效率的技巧,謝謝!

Andy2483

回復 14# Hsieh


    謝謝論壇,謝謝前輩
後學練習:
1.抓取資料列2倍的陣列
2.同一陣列前段是原始資料,後段放結果資料
3.再將前段原始資料清除
4.順排序將結果資料前挪
5.用字典產生變數
請前輩們指教

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

Andy2483

回復 14# Hsieh


    謝謝論壇,謝謝前輩
後學藉此帖練習陣列與字典,VBA的解決方案如下請各位前輩指教

執行前:

下載 (204.86 KB)

2023-3-29 13:17

執行結果:

下載 (233.17 KB)

2023-3-29 13:17

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

偉婕

謝謝[asimov]與[Hsieh]版主
重複計算的問題解決了,謝謝!

Hsieh

991002-1.rar (12.95 KB)

下載次數: 6

2010-10-3 00:45

定義名稱x=OFFSET(Sheet2!$A$1,,,COUNTA(Sheet2!$A:$A))
陣列公式{=SUM(IF((LEFT(SUBSTITUTE(x,D2,""))=";")+(RIGHT(SUBSTITUTE(x,D2,""),2)="; ")+(ISNUMBER(FIND("; ;",(SUBSTITUTE(x,D2,"")))))+(SUBSTITUTE(x,D2,"")=""),1,0))}

asimov

回復  偉婕
這公式確實有漏洞
如果D欄的國別在A欄不只出現一次就出錯了
再想想看除了VBA還有其他甚麼方 ...
Hsieh 發表於 2010-10-2 16:26

試試
E2
=SUMPRODUCT((ISNUMBER(FIND(";"&SUBSTITUTE(D2," ","")&";",";"&SUBSTITUTE($A$2:$A$75," ","")&";"))*1))

oobird

我寫不出這個公式，感覺vba的字典查詢才是最好的辦法。
若不想用vba，先剖析再用countif得了！

Hsieh

回復 10# 偉婕
這公式確實有漏洞
如果D欄的國別在A欄不只出現一次就出錯了
再想想看除了VBA還有其他甚麼方法可以完全比對

偉婕

回復 8# GBKEE

謝謝[GBKEE]版主,解決了[Serbia]重複計數[Serbia Monteneg]與[Ireland]重複計數[North Ireland]的問題


回復 9# Hsieh

[Hsieh]版主再提供的公式與我計算出來的結果有些出入
而且不明白[Hsieh]版主公式中的 (SUMPRODUCT(ISNUMBER(FIND($D2,OFFSET($D$1,,,COUNTA($DD),)))*1)-1) 為何要減1
謝謝!

Hsieh

=SUMPRODUCT(ISNUMBER(FIND($D2,OFFSET($A$1,,,COUNTA($A:$A),)))*1)-(SUMPRODUCT(ISNUMBER(FIND($D2,OFFSET($D$1,,,COUNTA($D:$D),)))*1)-1)