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

ivan731129

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

>>縣市別-序號-學校編號-學校名-類別-電話-地址-教學用途-通過日期-申請到期日期-人數<<
TEST1.rar (5.61 KB)

下載次數: 5

2011-3-1 22:41

PS.檔案重複的部份可能僅有名稱，用途的項目會不同，因此交集結果是學校在各檔案都有出現的才會挑出到新頁面新增
在測試中就是要三個頁面檔裡都有出現的苗栗的學校有交集輸出到新頁面


上一個檔案似乎用到較新的版本，另外付03版的
TEST.rar (4.49 KB)

下載次數: 7

2011-3-2 09:30

GBKEE

回復 1# ivan731129
請附範例檔案 上來

ivan731129

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

GBKEE

回復 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

回復 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

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