返回列表 上一主題 發帖

[發問] 關於新增資料的比對

[發問] 關於新增資料的比對

各位前輩好

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


非常謝謝!!


新增資料.rar (6.4 KB)

不好意思~
我剛想說中文網頁找不到類似的功能(有可能我自己關鍵字下錯^^")
所以我到國外找類似功能,發現一位 JLGWhiz 的回文對我的疑問有幫助
我稍微改寫了一下程式碼
但還是無法符合我預期的
跑出來的結果是這樣
問題.JPG
2016-6-24 14:26

我需要的是這樣
[attach]24551[/attach]

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

非常感謝:L

新增資料.rar (12.96 KB)

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 3# GBKEE

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

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

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

TOP

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

回復 4# Michelle-W
比對新增資料.rar (23.51 KB)
附上檔案供你測試。
比對新增資料(xls 格式).rar (13.85 KB)
如果你依然想用原本之宣告
  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

  17.         '  .Range("A1") = "姓名"
  18.         '  .Range("B1") = "年齡"
  19.         '  .Range("C1") = "婚姻"
  20.         .Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
  21.     End With
  22.    
  23.     For Each c In rng1                                          '  資料
  24.         Set cts = rng1.Find(c.Value, , LookIn:=xlValues)
  25.         
  26.         If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  27.             sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(cts.Row).Value    '  此次新增
  28.         End If
  29.     Next
  30. 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

  17.         '  .Range("A1") = "姓名"
  18.         '  .Range("B1") = "年齡"
  19.         '  .Range("C1") = "婚姻"
  20.         .Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
  21.     End With
  22.    
  23.     For Each c In rng1                                          '  資料
  24.         If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
  25.             sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(c.Row).Value    '  此次新增
  26.         End If
  27.     Next
  28. End Sub
複製代碼
其結果仍是一致的。
此端視你個人撰寫的經驗、習慣與邏輯思考。
比對新增資料(回歸原始).rar (16.91 KB)

TOP

回復 7# c_c_lai


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

真的非常謝謝您們兩位的教導!~~^^

TOP

        靜思自在 : 一個人的快樂.不是因為他擁有得多,而是因為他計較得少。
返回列表 上一主題