返回列表 上一主題 發帖

[發問] 詢問兩筆以上資料如何取交集合併新增(以解決)

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
159  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-7-3 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2011-3-2 10:05 | 顯示全部帖子
回復 3# ivan731129
  1. Sub Ex()
  2. Dim Sh As Worksheet, A As Range, k%, r&, Mystr$
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. For Each Sh In Sheets
  6.   With Sh
  7.      If .Name <> "集合檔" Then
  8.      k = k + 1
  9.         For Each A In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
  10.             Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 11))), ",")
  11.             If IsEmpty(d(A.Value)) Then '沒有的項目就加入
  12.                d(A.Value) = d(A.Value) + 1 '計算次數
  13.                d1(A.Value) = Mystr '紀錄內容
  14.                ElseIf d1(A.Value) = Mystr Then '相同時計算次數
  15.                d(A.Value) = d(A.Value) + 1 '計算次數
  16.                ElseIf d1(A.Value) <> Mystr Or d(A.Value) <> k Then '有不同或是與工作表數量不同
  17.                d1.Remove A.Value '移除項目
  18.             End If
  19.         Next
  20.     End If
  21. End With
  22. Next
  23. With Sheets("集合檔")
  24. .Cells = ""
  25. For Each ky In d1.keys
  26.    r = r + 1
  27.    .Cells(r, 1).Resize(, 11) = Split(d1(ky), ",") '寫入集合檔
  28. Next
  29. End With
  30. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
返回列表 上一主題