Board logo

標題: [發問] 對比不相同的資料 [打印本頁]
作者: john2006168    時間: 2010-5-19 10:20     標題: 對比不相同的資料

各位老師求教啊....
請看附件...我想把sheet1AB 跟 DE 對比不相同的資料有在sheet 2 show出來,但是不成功..請問程式哪兒出錯[attach]766[/attach]
作者: Hsieh    時間: 2010-5-19 18:17

回復 1# john2006168
  1. Sub Ex()
  2. Dim Ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set dc1 = CreateObject("Scripting.Dictionary")
  5. With Sheet1
  6.    For Each a In .Range(.[A2], .[A65536].End(xlUp))
  7.        d(a.Value) = a.Offset(, 1)
  8.    Next
  9.    For Each a In .Range(.[D2], .[D65536].End(xlUp))
  10.        dc1(a.Value) = a.Offset(, 1)
  11.    Next
  12. End With
  13. Sheet2.Columns("A:E") = ""
  14.    For Each ky In d.keys
  15.       If d(ky) <> dc1(ky) And d(ky) <> "" Then
  16.          ReDim Preserve Ar(s)
  17.          Ar(s) = Array(ky, d(ky))
  18.          s = s + 1
  19.       End If
  20.     Next
  21.     If s > 0 Then Sheet2.[A1].Resize(s, 2) = Application.Transpose(Application.Transpose(Ar))
  22.     s = 0: Erase Ar
  23.    For Each ky In dc1.keys
  24.       If d(ky) <> dc1(ky) And dc1(ky) <> "" Then
  25.          ReDim Preserve Ar(s)
  26.          Ar(s) = Array(ky, dc1(ky))
  27.          s = s + 1
  28.       End If
  29.     Next
  30.     If s > 0 Then Sheet2.[D1].Resize(s, 2) = Application.Transpose(Application.Transpose(Ar))
  31. End Sub
複製代碼
作者: john2006168    時間: 2010-5-19 22:52

先多謝老師,這麼多程序.要慢慢消化一下.
作者: sping    時間: 2010-6-23 11:47

[attach]1381[/attach]回復 2# Hsieh

Hsieh你好
因為我也有資料比對的需求，我有依你的程式碼作了一個小更改，因為我比對的資料欄位有數字格式，也可能有文字格式，所以就將a及b欄儲存格設為「文字格式」，可是設完後比對結果就會發生錯誤，可否請版主幫我看看，謝謝。
[attach]1381[/attach]
ps如果我將a及b來欄儲存格改為「通用格式」比對就會正常，可是當資料是「0800」時就會變成「800」這樣我的資料就會比對錯誤﹞
作者: Hsieh    時間: 2010-6-23 12:16

回復 4# sping
  1. Sub 同工作表不同欄位之比對()
  2. Dim Ar(), Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. Set d2 = CreateObject("Scripting.Dictionary")
  6. With Sheets("同工作表之比對")
  7. For Each a In .Range(.[A3], .[A65536].End(xlUp))
  8.    d(a.Text) = a.Text
  9.    d2(a.Text) = a.Text
  10. Next
  11. For Each a In .Range(.[B3], .[B65536].End(xlUp))
  12.    d1(a.Text) = a.Text
  13.    d2(a.Text) = a.Text
  14. Next
  15. ReDim Preserve Ar(s): Ar(s) = "相同Name": s = s + 1
  16. ReDim Preserve Ay(k): Ay(k) = "不同Name": k = k + 1
  17. For Each ky In d2.keys
  18.   If d.exists(ky) = True And d1.exists(ky) = True Then
  19.   ReDim Preserve Ar(s) '相同
  20.   Ar(s) = ky
  21.   s = s + 1
  22.   Else
  23.   ReDim Preserve Ay(k) '不同
  24.   Ay(k) = ky
  25.   k = k + 1
  26.   End If
  27. Next
  28. Range("c3:d65536") = ""
  29. .[c2].Resize(s, 1) = Application.Transpose(Ar)
  30. .[d2].Resize(k, 1) = Application.Transpose(Ay)
  31. End With
  32. End Sub
複製代碼
作者: GBKEE    時間: 2010-6-23 16:09

請各位看看4樓的附檔  工作表中僅A-D欄  會有一奇怪的現象
在列的最底端位置 按下[Ctrl+往上鍵]  第1次就會到最頂端有資料的儲存格的列位. 完全不理會中間的儲存格是否有資料
在第1列的位置 [Ctrl+往下鍵]   第1次會到有資料的儲存格的位置. 第2 次便直接會到列的最底端位置. 也完全不理會中間的儲存格是否有資料
作者: Hsieh    時間: 2010-6-23 16:24

回復 6# GBKEE


    有文字符號'存在
用資料剖析讓'消失即可恢復正常
作者: sping    時間: 2010-6-23 18:37

回復 5# Hsieh

Hsieh 您好
謝謝你抽空幫我看程式。
可是後來用你改好的程式碼去執行，有時候仍會發生錯誤，不曉得是我操作錯誤還是程式碼有問題
我附上兩個檔案，都是一樣的程式碼，可是執行結果會有差異，麻煩Hsieh版主或各位前輩幫我看看，謝謝
[attach]1390[/attach]
[attach]1391[/attach]
作者: Hsieh    時間: 2010-6-23 18:53

原因是你的a:d欄空格含有看不見字元
用資料剖析把文字辨識符號取消即可
[attach]1393[/attach]
[attach]1394[/attach]
作者: GBKEE    時間: 2010-6-23 19:06

回復 7# Hsieh 謝謝 Hsieh 板主 解答
請問 你是如何找出的 我用AscB函數找不出來
作者: sping    時間: 2010-6-23 19:10

回復 9# Hsieh

謝謝Hsieh版主幫我解決困擾了。
作者: Hsieh    時間: 2010-6-23 19:51

回復 10# GBKEE
沒有正規方法
當我發現整欄會被認為有資料時
而且CODE函數讀取內容卻會出錯,就知道含有不可見字元
要清除它不是用delete就是用資料剖析最快
作者: GBKEE    時間: 2010-6-24 06:58

回復 12# Hsieh
謝謝Hsieh板主的解說
當我執行你的程式後的結果 不是預期的 只發現Ctrl+方向鍵有異 但沒有朝不可見字元方向想
可是它好像只要用資料剖析就可以恢復正常 卻找不出是那一個不可見字元
作者: GBKEE    時間: 2010-6-24 20:41

回復 4# sping
純參考
用Find方法
   
  1. Sub 同工作表不同欄位之比對()
  2. Dim Rng(1 To 2) As Range, F As Range, d1 As Object, d2 As Object, A As Range
  3. Set d1 = CreateObject("Scripting.Dictionary")
  4. Set d2 = CreateObject("Scripting.Dictionary")
  5. d1("相同Name") = ""
  6. d2("不相同Name") = ""
  7. With Sheets("同工作表之比對")
  8.     Set Rng(1) = .Range("A3", .Range("A" & Rows.Count).End(xlUp))
  9.     Set Rng(2) = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
  10.     For Each A In .Range(Rng(1).Address & "," & Rng(2).Address)
  11.         If A <> "" Then
  12.             Set F = Rng(IIf(A.Column = Rng(1).Column, 2, 1)).Find(A.Text, lookat:=xlWhole)
  13.             If Not F Is Nothing Then
  14.                 d1(A.Text) = ""
  15.             Else
  16.                 d2(A.Text) = ""
  17.             End If
  18.         End If
  19.     Next
  20. End With
  21. With Sheets("同工作表之比對")
  22.     .Range("c3:d65536") = ""
  23.     .[c2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  24.     .[d2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
  25. End With
  26. End Sub
複製代碼
作者: sping    時間: 2010-6-24 21:45

回復 14# GBKEE


    謝謝你熱心幫忙修改，你和hsieh版主的程式碼對我都很有幫助，我會留下來研究。
作者: 198188    時間: 2012-11-9 10:14

如果是不同的excel呢？怎樣寫？c:\....?
作者: 198188    時間: 2012-11-9 10:29

Sub sample()

Dim LastRec As Integer
Dim j As Integer
Dim i As Integer
Dim l As Integer
Dim data() As Range
l = 1

Worksheets("Sheet1").Range("A1").Select
ActiveCell.End(xlDown).Select
     LastRec = ActiveCell.Row
     

For j = 1 To LastRec

i = Application.Match(Sheet1.Cells(1, j), "='C:\Users\Desktop\[1.xlsx]Sheet1'!.Range("A:A"), 0)

If Sheet1.Cells(i, 2).Value <> Sheet2.Cells(i, 2).Value Then

Sheet1.Cells(i, 2).Value = Sheet2.Cells(i, 2).Value
Sheet1.Cells(i, 2).Interior.Color = RGB(255, 200, 255)
End If

Next j

End Sub
請問i = Application.Match(Sheet1.Cells(1, j), "='C:\Users\Desktop\[1.xlsx]Sheet1'!.Range("A:A"), 0)這句哪裡出錯？我想在一個excel內找出桌面的另一個（1.xlsx) excel內相同的名稱，如果他們的值不同就改成另一個（1.xlsx) excel內的值
作者: 198188    時間: 2012-11-9 10:33

另外請問vba可否讓一個excel 可以同時讓多位用家使用，輸入資料及儲存？
作者: Hsieh    時間: 2012-11-9 17:48

不同檔案間做比對就必須兩個檔案都在開啟狀態下讀取資料比對
不妨將檔案上傳以便了解資料結構
作者: 198188    時間: 2012-11-9 21:48

回復 20# Hsieh


    要同時打開沒問題，但如何寫？
我有見過有人寫的vba不用打開兩個檔案，就可以vlookup相同名，然後就同名的相應資料傳回在當前的sheet內同名的相對位置
作者: 198188    時間: 2012-11-10 00:31

回復 23# Hsieh


    [attach]13089[/attach]

請問如何在outstanding payments 根據order在HK ETA UPDATE的表內找尋相同ORDER，然後對比該ORDER 的ETA，如果兩個不同，就將OUTSTANDING PAYMENTS 表內的ETA 改成 HK ETA UPDATE表內的ETA (相同ORDER)，以及將改的那字改為紅色！如果對比兩個表相同ORDER的ETA相同就不變，而OUTSTANDING PAYMENTS內的ORDER如果在HK ETA UPDATE表內沒有，也不變！



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