[發問] 不對稱日期做比對後要如何刪除不相同的部分使之對齊資料

yuch8663

aaa.rar (7.4 KB)

下載次數: 6

2012-5-28 11:44

請問每日要上網蒐集四組對照資料，但不一定會同日都有數據，故每兩組資料裡的日期組(例如data1-1與data1-2)，會出現日期資料不能相對應的情況，要如何寫一個能兩相比對後刪除不對應日期的程式

Andy2483

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

執行前:

下載 (471.61 KB)

2023-4-11 10:26

執行結果:

下載 (456.5 KB)

2023-4-11 10:26

Option Explicit
Sub TEST()
Dim Brr, Crr, A(2), Y, Z, N&, i&, j&, xR As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("sheet2"): Set xR = Sh.UsedRange.Offset(1, 0): Brr = xR
For i = 0 To UBound(A)
   A(i) = Intersect(xR, [A:H].Offset(0, i * 8))
   For j = 1 To UBound(A(i))
      Y(A(i)(j, 2)) = Y(A(i)(j, 2)) + 1: Y(A(i)(j, 2) & "|" & i) = j
   Next
Next
For Each Z In Y.keys
   If Y(Z) = UBound(A) + 1 And InStr(Z, "|") = 0 And Z <> "" Then
      N = N + 1
      For i = 0 To UBound(A)
         For j = 1 To 8
            Brr(N, j + 8 * i) = Brr(Y(Z & "|" & i), j + 8 * i)
         Next
      Next
   End If
Next
xR.ClearContents
[A2].Resize(N, 8 * (UBound(A) + 1)) = Brr
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase A, Brr
End Sub

yuch8663

謝謝hsieh、 register313兩位版主的指導，我再來測試。

Hsieh

回復 5# yuch8663

試試自己輸入日期欄位與欄數以符合任意表格比對

1. Sub nn()
   
2. Dim k%, s&, j&, n%, n1%, i%, Ay(), Ar()
   
3. Set d = CreateObject("Scripting.Dictionary") '所有日期容器
   
4. Set d1 = CreateObject("Scripting.Dictionary") 'data1容器
   
5. Set d2 = CreateObject("Scripting.Dictionary") 'data2容器
   
6. n = InputBox("輸入第一個日期欄位值", , 2) '輸入第一個日期欄位
   
7. n1 = InputBox("輸入日期欄位差", , 8) '輸入2表格日期欄位相差欄位數
   
8. ReDim A(n1) '每個data的欄位數量
   
9. ReDim C(n1 * 2) '2表格總欄數
   
10. Ar = Range("A1").CurrentRegion.Offset(1).Value 'A2開始以下所有資料集合
    
11. For k = n To UBound(Ar, 2) Step n1 * 2  '從第一個日期欄位開始，以欄位差為級距做欄位回圈
    
12.    For i = 0 To n1 Step n1  '在data1與data2的日期欄位
    
13.      For j = 1 To UBound(Ar, 1) '以列作迴圈
    
14.       d(Ar(j, k + i)) = "" '紀錄日期
    
15.       For x = 0 To n1 - 1
    
16.          A(x) = Ar(j, k + i - (n - x - 1)) '寫入暫存陣列
    
17.       Next
    
18.       If i = 0 Then d1(Ar(j, k + i)) = A '將陣列傳給字典
    
19.       If i = n1 Then d2(Ar(j, k + i)) = A '將陣列傳給字典
    
20.      Next
    
21.    Next
    
22.    For Each ky In d.keys
    
23.       If d1.exists(ky) = True And d2.exists(ky) = True Then '如果2個data容器都找到此索引
    
24.       For i = 0 To n1 * 2 - 1
    
25.         If i < n1 Then C(i) = d1(ky)(i) Else C(i) = d2(ky)(i - n1) '寫入暫存陣列
    
26.       Next
    
27.       ReDim Preserve Ay(s) '將暫存陣列傳給動態陣列
    
28.       Ay(s) = C
    
29.       s = s + 1
    
30.       End If
    
31.    Next
    
32.   Range(Cells(2, k - (n - 1)).Resize(, n1 * 2), Cells(Rows.Count, k - (n - 1)).Resize(, n1 * 2)) = "" '清除資料
    
33.   Cells(2, k - (n - 1)).Resize(s, n1 * 2) = Application.Transpose(Application.Transpose(Ay)) '寫入資料
    
34.   s = 0: Erase Ay '清空陣列
    
35.   d.RemoveAll '移除字典內容
    
36.   d1.RemoveAll '移除字典內容
    
37.   d2.RemoveAll '移除字典內容
    
38. Next
    
39. End Sub

複製代碼

register313

回復 5# yuch8663

用原方法修改,但直接取代SHEET2

1. Sub yy()
   
2. Dim Ar1(), Ar2()
   
3.   Set d1 = CreateObject("scripting.dictionary")
   
4.   Set d2 = CreateObject("scripting.dictionary")
   
5.   Sheets("sheet2").Select
   
6.   x = Cells(2, "A").End(xlDown).Row
   
7.   y = Cells(2, "I").End(xlDown).Row
   
8.   Ar1 = Range(Cells(2, "A"), Cells(x, "H"))
   
9.   Ar2 = Range(Cells(2, "I"), Cells(y, "P"))
   
10.   For I = 1 To UBound(Ar1)
    
11.     d1(Ar1(I, 2)) = Application.Index(Ar1, I, 0)
    
12.   Next I
    
13.   For I = 1 To UBound(Ar2)
    
14.     d2(Ar2(I, 2)) = Application.Index(Ar2, I, 0)
    
15.   Next I
    
16.   For J = 1 To UBound(Ar1)
    
17.     If Not d2.Exists(Ar1(J, 2)) Then d1.Remove (Ar1(J, 2))
    
18.   Next J
    
19.   For J = 1 To UBound(Ar2)
    
20.     If Not d1.Exists(Ar2(J, 2)) Then d2.Remove (Ar2(J, 2))
    
21.   Next J
    
22.   [A1].CurrentRegion.Offset(1, 0) = ""
    
23.   [A2].Resize(d1.Count, 8) = Application.Transpose(Application.Transpose(d1.items))
    
24.   [I2].Resize(d2.Count, 8) = Application.Transpose(Application.Transpose(d2.items))
    
25. End Sub

複製代碼

aaa1.rar (178.04 KB)

下載次數: 6

2012-5-29 21:47

yuch8663

請問Hsieh版大
您的這組程式我套用後，當資料量變多時，整個程式會當掉，而register313 版主的則不會，同樣是運用陣列的方式，為何會如此?
另外請教如果兩組的範圍變大(例如sheet2 的資料)，要怎麼修改謝謝。
aaa1.rar (176.41 KB)

下載次數: 7

2012-5-29 15:24

yuch8663

謝謝register313、 Hsieh 兩位版主的幫忙，我本來還在參考用
Do
Loop Until  [一直到條件為]  離開迴圈
不過版主們使用陣列的語法速度更快，謝謝

Hsieh

回復 1# yuch8663
在同一工作表直接刪除不對應資料

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For k = 1 To [IV1].End(xlToLeft).Column Step 4 '欄位
   
4. For I = 0 To 2 Step 2 '日期欄位
   
5.    For Each a In Range(Cells(1, k + I), Cells(1, k + I).End(xlDown)) '每個日期
   
6.      If Application.CountIf(Cells(1, k).Resize(, 3).EntireColumn, a) > 1 Then
   
7.        If IsEmpty(d(a.Value)) Then '第一次遇到日期
   
8.           d(a.Value) = Array(a.Value, a.Offset(, 1).Value, a.Value, "")
   
9.           Else '第二次日期
   
10.           ar = d(a.Value)
    
11.           ar(3) = a.Offset(, 1).Value
    
12.           d(a.Value) = ar
    
13.           Erase ar
    
14.         End If
    
15.      End If
    
16.     Next
    
17. Next
    
18. Cells(1, k).Resize(, 4).EntireColumn = "" '清空
    
19. Cells(1, k).Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items)) '寫入
    
20. d.RemoveAll '移除字典內容
    
21. Next
    
22. End Sub

複製代碼

register313

回復 1# yuch8663

1. Sub xx()
   
2. Dim Ar1(), Ar2()
   
3. Sheets("sheet2").Cells = ""
   
4. Sheets("sheet1").Rows(1).Copy Sheets("sheet2").Rows(1)
   
5. For C = 1 To 15 Step 4
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Set d2 = CreateObject("scripting.dictionary")
   
8.   Sheets("sheet1").Select
   
9.   x = Cells(2, C).End(xlDown).Row
   
10.   y = Cells(2, C + 2).End(xlDown).Row
    
11.   Ar1 = Range(Cells(2, C), Cells(x, C + 1))
    
12.   Ar2 = Range(Cells(2, C + 2), Cells(y, C + 3))
    
13.   For I = 1 To UBound(Ar1)
    
14.     d1(Ar1(I, 1)) = Ar1(I, 2)
    
15.   Next I
    
16.   For I = 1 To UBound(Ar2)
    
17.     d2(Ar2(I, 1)) = Ar2(I, 2)
    
18.   Next I
    
19.   For J = 1 To UBound(Ar1)
    
20.     If Not d2.Exists(Ar1(J, 1)) Then d1.Remove (Ar1(J, 1))
    
21.   Next J
    
22.   For J = 1 To UBound(Ar2)
    
23.     If Not d1.Exists(Ar2(J, 1)) Then d2.Remove (Ar2(J, 1))
    
24.   Next J
    
25.   Sheets("sheet2").Cells(2, C).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
26.   Sheets("sheet2").Cells(2, C + 1).Resize(d1.Count, 1) = Application.Transpose(d1.items)
    
27.   Sheets("sheet2").Cells(2, C + 2).Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
28.   Sheets("sheet2").Cells(2, C + 3).Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
29.   Erase Ar1: Erase Ar2
    
30.   Set d1 = Nothing: Set d2 = Nothing
    
31. Next C
    
32. End Sub

複製代碼

aaa1.rar (13.17 KB)

下載次數: 9

2012-5-28 15:08