Board logo

標題: [發問] 關於新增資料的比對 [打印本頁]
作者: Michelle-W    時間: 2016-6-24 13:15     標題: 關於新增資料的比對

各位前輩好

小妹是VBA的初學者，目前遇到一個瓶頸:L  (有在網路上爬過文，但找不到類似功能的寫法)
"資料"的工作表 想要去跟 現有"List"工作表做比對，比對後"資料"若有新增的，則貼到"此次新增的"工作表裡面
請問有哪一位前輩可以指點一下程式碼如何撰寫嗎?


非常謝謝!!


[attach]24550[/attach]
作者: Michelle-W    時間: 2016-6-24 14:28

不好意思~
我剛想說中文網頁找不到類似的功能(有可能我自己關鍵字下錯^^")
所以我到國外找類似功能，發現一位 JLGWhiz 的回文對我的疑問有幫助
我稍微改寫了一下程式碼
但還是無法符合我預期的
跑出來的結果是這樣
[attach]24552[/attach]
我需要的是這樣
[attach]24551[/attach]

請問有誰能幫忙修改一下程式碼嗎?(困擾我好久的問題QQ...)

非常感謝:L

[attach]24553[/attach]
作者: GBKEE    時間: 2016-6-25 14:46

回復 2# Michelle-W

試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, d_New As Object, i As Double, s   As String, k As Variant
  4.     Set d = CreateObject("scripting.dictionary")          ' 字典物件 : List資料
  5.     Set d_New = CreateObject("scripting.dictionary") ' 字典物件 : 比對出 List 所沒有的資料
  6.     With Sheets("List").UsedRange
  7.         For i = 2 To .Rows.Count
  8.             s = Join(Application.Transpose(Application.Transpose(.Rows(i).Value)), ",")
  9.             d(s) = .Rows(i)
  10.         Next
  11.     End With
  12.     With Sheets("資料").UsedRange
  13.         For i = 1 To .Rows.Count
  14.             s = Join(Application.Transpose(Application.Transpose(.Rows(i).Value)), ",")
  15.             If d.EXiSTS(s) = False Then d_New(s) = .Rows(i)
  16.         Next
  17.     End With
  18.     With Sheets("此次新增").UsedRange
  19.         .Clear
  20.         If d_New.Count > 1 Then
  21.             i = 1
  22.             For Each k In d_New.KEYS
  23.                 .Cells(i, "A").Resize(, 3) = d_New(k)
  24.                 i = i + 1
  25.             Next
  26.         Else
  27.             MsgBox "此次新增 沒有 新增資料 !"
  28.         End If
  29.     End With
  30. End Sub
複製代碼
作者: Michelle-W    時間: 2016-6-25 17:07

回復 3# GBKEE

非常謝謝版主!! 可以運作了~^^
另外想請教版主一下
如果每個sheet 第一列直接是資料(沒有姓名、年齡、婚姻)
請問程式碼要怎麼微調? 第一列的資料都會一起帶入此次新增的工作表裡面QQ"
作者: GBKEE    時間: 2016-6-26 14:04

回復 4# Michelle-W
  1. With Sheets("List").UsedRange
  2.        For i = 2 To .Rows.Count
複製代碼
那就從第一列開始
  1. With Sheets("List").UsedRange
  2.        For i = 1 To .Rows.Count
複製代碼
作者: c_c_lai    時間: 2016-6-26 20:58

回復 2# Michelle-W
其實你原本之程式碼稍加調整，
也是可行的：
  1. Sub 比對新增()
  2.     Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
  3.     Dim rng1 As Range, rng2 As Range, c As Variant, cts As Variant, ct2 As Variant
  4.    
  5.     Set sh1 = Sheets(1)        '  資料
  6.     Set sh2 = Sheets(2)        '  List
  7.     Set sh3 = Sheets(3)        '  此次新增
  8.    
  9.     lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row    '  資料
  10.     lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row    '  List
  11.    
  12.     Set rng1 = sh1.Range("A1:A" & lr1)        '  資料
  13.     Set rng2 = sh2.Range("A1:A" & lr2)        '  List
  14.    
  15.     With sh3                                  '  此次新增
  16.         .Cells.Clear

  18.         '  .Range("A1") = "姓名"
  19.         '  .Range("B1") = "年齡"
  20.         '  .Range("C1") = "婚姻"
  21.         .Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
  22.     End With
  23.    
  24.     For Each c In rng1                                          '  資料
  25.         Set cts = rng1.Find(c.Value, , LookIn:=xlValues)
  26.         Set ct2 = rng2.Find(c.Value, , LookIn:=xlValues)
  27.         '  If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  28.         If Not cts Is Nothing And ct2 Is Nothing Then                                          '  List
  29.             sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(cts.Row).Value    '  此次新增
  30.         End If
  31.     Next
  32. End Sub
複製代碼
GBKEE 版大那兒，你也可以學到不錯的觀念與技巧。
作者: c_c_lai    時間: 2016-6-26 21:22

本帖最後由 c_c_lai 於 2016-6-27 06:13 編輯

回復 4# Michelle-W
[attach]24560[/attach]
附上檔案供你測試。
[attach]24561[/attach]
如果你依然想用原本之宣告
  1. If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  2.        .
  3.        .
  4. End If
複製代碼
亦可， 其與樓上 (#6) 的
  1. If Not cts Is Nothing And ct2 Is Nothing Then
  2.        .
  3.        .
  4. End If
複製代碼
表述是異曲同工。(省略了 ct2 的變數宣告與給予值 (Assign Value) 的設定 )
  1. Sub 比對新增2()
  2.     Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
  3.     Dim rng1 As Range, rng2 As Range, c As Variant, cts As Variant
  4.    
  5.     Set sh1 = Sheets(1)        '  資料
  6.     Set sh2 = Sheets(2)        '  List
  7.     Set sh3 = Sheets(3)        '  此次新增
  8.    
  9.     lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row    '  資料
  10.     lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row    '  List
  11.    
  12.     Set rng1 = sh1.Range("A1:A" & lr1)        '  資料
  13.     Set rng2 = sh2.Range("A1:A" & lr2)        '  List
  14.    
  15.     With sh3                                  '  此次新增
  16.         .Cells.Clear

  18.         '  .Range("A1") = "姓名"
  19.         '  .Range("B1") = "年齡"
  20.         '  .Range("C1") = "婚姻"
  21.         .Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
  22.     End With
  23.    
  24.     For Each c In rng1                                          '  資料
  25.         Set cts = rng1.Find(c.Value, , LookIn:=xlValues)
  26.         
  27.         If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  28.             sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(cts.Row).Value    '  此次新增
  29.         End If
  30.     Next
  31. End Sub
複製代碼
抑或是根本不使用  cts、ct2 的兩個變數宣告與給予值 (Assign Value) 的設定
  1. Sub 比對新增3()
  2.     Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
  3.     Dim rng1 As Range, rng2 As Range, c As Variant
  4.    
  5.     Set sh1 = Sheets(1)        '  資料
  6.     Set sh2 = Sheets(2)        '  List
  7.     Set sh3 = Sheets(3)        '  此次新增
  8.    
  9.     lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row    '  資料
  10.     lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row    '  List
  11.    
  12.     Set rng1 = sh1.Range("A1:A" & lr1)        '  資料
  13.     Set rng2 = sh2.Range("A1:A" & lr2)        '  List
  14.    
  15.     With sh3                                  '  此次新增
  16.         .Cells.Clear

  18.         '  .Range("A1") = "姓名"
  19.         '  .Range("B1") = "年齡"
  20.         '  .Range("C1") = "婚姻"
  21.         .Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
  22.     End With
  23.    
  24.     For Each c In rng1                                          '  資料
  25.         If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  26.             sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(c.Row).Value    '  此次新增
  27.         End If
  28.     Next
  29. End Sub
複製代碼
其結果仍是一致的。
此端視你個人撰寫的經驗、習慣與邏輯思考。
[attach]24562[/attach]
作者: Michelle-W    時間: 2016-6-27 17:13

回復 7# c_c_lai


您修改的程式碼都可以用
因為我是自學的初學者，還看不懂太多
不過我還是會努力搞懂的

真的非常謝謝您們兩位的教導!~~^^
作者: Andy2483    時間: 2023-5-25 16:19

本帖最後由 Andy2483 於 2023-5-25 16:32 編輯

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

List資料庫:
[attach]36435[/attach]

資料表(新比對資料):
[attach]36436[/attach]

結果表執行前:
[attach]36437[/attach]

執行結果:
[attach]36438[/attach]


Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j&, T$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是字典
Brr = Range([List!C1], [List!A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以List表A~C欄儲存格值帶入陣列裡
For i = 2 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3): Y(T) = i
   '↑令以每個迴圈3欄值組成的新字串當key,item是列號,納入Y字典
Next
Brr = Range([資料!C1], [資料!A65536].End(xlUp))
'↑令Br陣列,換裝資料表A~C欄儲存格值
For i = 2 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3)
   If Y(T) <> "" Then GoTo i01
   '↑如果以迴圈3欄值組成的新字串查Y字典得item值不是空的,
   '就跳到標示i01位置繼續執行
   R = R + 1
   '↑令R變數累加1
   For j = 1 To 3: Brr(R, j) = Brr(i, j): Next
   '↑設順迴圈!將Brr陣列值往上謄,將原陣列值覆蓋
i01: Next
If R = 0 Then MsgBox "無新增": GoTo i02
'↑如果R變數是初始值0,就跳到標示i02位置繼續執行
With Sheets("此次新增")
   .UsedRange.Offset(1, 0).Clear
   '↑將結果表有使用儲存格往下偏移1列的範圍清除
   .[A2].Resize(R, 3) = Brr
   '↑令Brr陣列值寫入結果表中,超出範圍的陣列值忽略
End With
i02: Set Y = Nothing: Erase Brr
'↑令釋放變數
End Sub

=============================================
補充: 以下是將結果資料謄入另一陣列的方法

Option Explicit
Sub TEST_1()
Dim Brr, Crr, Y, R&, i&, j&, T$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是字典
Brr = Range([List!C1], [List!A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以List表A~C欄儲存格值帶入陣列裡
For i = 2 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3): Y(T) = i
   '↑令以每個迴圈3欄值組成的新字串當key,item是列號,納入Y字典
Next
Brr = Range([資料!C1], [資料!A65536].End(xlUp))
'↑令Br陣列,換裝資料表A~C欄儲存格值
ReDim Crr(1 To UBound(Brr), 1 To 3)
'↑宣告Crr變數是 二維空陣列,縱向範圍同Brr,橫向1~3
For i = 2 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3)
   If Y(T) <> "" Then GoTo i01
   '↑如果以迴圈3欄值組成的新字串查Y字典得item值不是空的,
   '就跳到標示i01位置繼續執行
   R = R + 1
   '↑令R變數累加1
   For j = 1 To 3: Crr(R, j) = Brr(i, j): Next
   '↑設順迴圈!將Brr陣列值寫入Crr陣列中
i01: Next
If R = 0 Then MsgBox "無新增": GoTo i02
'↑如果R變數是初始值0,就跳到標示i02位置繼續執行
With Sheets("此次新增")
   .UsedRange.Offset(1, 0).Clear
   '↑將結果表有使用儲存格往下偏移1列的範圍清除
   .[A2].Resize(R, 3) = Crr
   '↑令Crr陣列值寫入結果表中,超出範圍的陣列值忽略
End With
i02: Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub



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