Board logo

標題: [發問] 詢問兩筆以上資料如何取交集合併新增(以解決) [打印本頁]
作者: ivan731129    時間: 2011-3-1 17:18     標題: 詢問兩筆以上資料如何取交集合併新增(以解決)

本帖最後由 ivan731129 於 2011-3-2 10:27 編輯

請問各位前輩關於想要合併兩個以上的檔案 或是 同一檔案下不同頁面的交集 該如何去寫巨集呢?
檔案格式如下，想知道要以某項目為對應參造的寫法，因為翻了前面的問題沒找到比較合用來修改的。
想請前輩們幫忙。

>>縣市別-序號-學校編號-學校名-類別-電話-地址-教學用途-通過日期-申請到期日期-人數<<
[attach]4891[/attach]
PS.檔案重複的部份可能僅有名稱，用途的項目會不同，因此交集結果是學校在各檔案都有出現的才會挑出到新頁面新增
在測試中就是要三個頁面檔裡都有出現的苗栗的學校有交集輸出到新頁面


上一個檔案似乎用到較新的版本，另外付03版的
[attach]4892[/attach]
作者: GBKEE    時間: 2011-3-1 17:39

回復 1# ivan731129
請附範例檔案 上來
作者: ivan731129    時間: 2011-3-2 09:37

本帖最後由 ivan731129 於 2011-3-2 09:42 編輯

感謝GBKEE 大快速的回答，不過測試時發現他執行為有交集就輸出
但是我必須要多個檔案內都有才輸出的話要如何修改。
就是當有三檔的話，苗栗地區要是有兩個學校 一個出現在兩檔中、一個出現在三檔中
那我只要輸出三個都有出現那所的話要如何修改呢?
作者: GBKEE    時間: 2011-3-2 09:54

回復 3# ivan731129
03版
  1. Sub Ex()
  2.     Dim D(1 To 2) As Object, R, SH As Worksheet, T As String, I As Integer, AR(), A
  3.     Dim ShCount As Integer
  4.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
  5.     Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
  6.     With Sheets("集合檔")
  7.         .Cells.Clear
  8.         For Each SH In Sheets
  9.             If SH.Name = "集合檔" Then Exit For
  10.             ShCount = ShCount + 1
  11.             For Each R In SH.Range("A1").CurrentRegion.Rows
  12.                 T = R.Cells(1) & "," & Join(Application.Transpose(Application.Transpose(R.Cells(1, 1).Resize(1, 8))), ",")
  13.                 If D(1).Exists((T)) = False Then
  14.                     D(1)(T) = Array(False, 1)
  15.                     D(2)(T) = Array(Join(Application.Transpose(Application.Transpose(R)), ","))
  16.                 Else
  17.                      D(1)(T) = Array(True, D(1)(T)(1) + 1)
  18.                      If R.Row <> 1 Then
  19.                         AR = D(2)(T)
  20.                         ReDim Preserve AR(UBound(AR) + 1)
  21.                         AR(UBound(AR)) = Join(Application.Transpose(Application.Transpose(R)), ",")
  22.                         D(2)(T) = AR
  23.                     End If
  24.                 End If
  25.             Next
  26.         Next
  27.         For Each R In D(1).KEYS
  28.             If D(1)(R)(0) = True And D(1)(R)(1) = ShCount Then  'D(1)(R)(1) = ShCount 每個資料庫都出現
  29.                 For Each A In D(2)(R)
  30.                     I = I + 1
  31.                     .Cells(I, 1).Resize(1, UBound(Split(A, ",")) + 1) = Split(A, ",")
  32.                 Next
  33.             End If
  34.         Next
  35.     End With
  36. End Sub
複製代碼
作者: Hsieh    時間: 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
複製代碼
作者: ivan731129    時間: 2011-3-2 10:14

本帖最後由 ivan731129 於 2011-3-2 10:22 編輯

測試ok了，不過Hsieh大的巨集不知是對應哪項目會變成單筆資料 。
但是太感謝兩位板主的熱心指導，
我要好好研究一下寫法了。



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)