返回列表 上一主題 發帖

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

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2016-6-24 13:15 | 只看該作者

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

各位前輩好

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


非常謝謝!!


新增資料.rar (6.4 KB)
收藏 分享

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
2#
發表於 2016-6-24 14:28 | 只看該作者
不好意思~
我剛想說中文網頁找不到類似的功能(有可能我自己關鍵字下錯^^")
所以我到國外找類似功能，發現一位 JLGWhiz 的回文對我的疑問有幫助
我稍微改寫了一下程式碼
但還是無法符合我預期的
跑出來的結果是這樣
問題.JPG
2016-6-24 14:26

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

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

非常感謝:L

新增資料.rar (12.96 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
4#
發表於 2016-6-25 17:07 | 只看該作者
回復 3# GBKEE

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
6#
發表於 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 版大那兒，你也可以學到不錯的觀念與技巧。

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
7#
發表於 2016-6-26 21:22 | 只看該作者
本帖最後由 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

  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
複製代碼
其結果仍是一致的。
此端視你個人撰寫的經驗、習慣與邏輯思考。
比對新增資料(回歸原始).rar (16.91 KB)

TOP

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
8#
發表於 2016-6-27 17:13 | 只看該作者
回復 7# c_c_lai


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

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

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1425 
主題
40 
精華
0 
積分
1449 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-4-16 
9#
發表於 2023-5-25 16:19 | 只看該作者
本帖最後由 Andy2483 於 2023-5-25 16:32 編輯

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

List資料庫:
20230525_1.jpg
2023-5-25 16:15


資料表(新比對資料):
20230525_2.jpg
2023-5-25 16:17


結果表執行前:
20230525_3.jpg
2023-5-25 16:17


執行結果:
20230525_4.jpg
2023-5-25 16:18



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 受人點水之恩，須當湧泉以報。
返回列表 上一主題