關於新增資料的比對
各位前輩好小妹是VBA的初學者，目前遇到一個瓶頸:L (有在網路上爬過文，但找不到類似功能的寫法)
"資料"的工作表 想要去跟 現有"List"工作表做比對，比對後"資料"若有新增的，則貼到"此次新增的"工作表裡面
請問有哪一位前輩可以指點一下程式碼如何撰寫嗎?
非常謝謝!!
[attach]24550[/attach] 不好意思~
我剛想說中文網頁找不到類似的功能(有可能我自己關鍵字下錯^^")
所以我到國外找類似功能，發現一位 JLGWhiz 的回文對我的疑問有幫助
我稍微改寫了一下程式碼
但還是無法符合我預期的
跑出來的結果是這樣
[attach]24552[/attach]
我需要的是這樣
[attach]24551[/attach]
請問有誰能幫忙修改一下程式碼嗎?(困擾我好久的問題QQ...)
非常感謝:L
[attach]24553[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91757&ptid=17831]2#[/url] [i]Michelle-W[/i] [/b]
試試看[code]Option Explicit
Sub Ex()
Dim d As Object, d_New As Object, i As Double, s As String, k As Variant
Set d = CreateObject("scripting.dictionary") ' 字典物件 : List資料
Set d_New = CreateObject("scripting.dictionary") ' 字典物件 : 比對出 List 所沒有的資料
With Sheets("List").UsedRange
For i = 2 To .Rows.Count
s = Join(Application.Transpose(Application.Transpose(.Rows(i).Value)), ",")
d(s) = .Rows(i)
Next
End With
With Sheets("資料").UsedRange
For i = 1 To .Rows.Count
s = Join(Application.Transpose(Application.Transpose(.Rows(i).Value)), ",")
If d.EXiSTS(s) = False Then d_New(s) = .Rows(i)
Next
End With
With Sheets("此次新增").UsedRange
.Clear
If d_New.Count > 1 Then
i = 1
For Each k In d_New.KEYS
.Cells(i, "A").Resize(, 3) = d_New(k)
i = i + 1
Next
Else
MsgBox "此次新增 沒有 新增資料 !"
End If
End With
End Sub
[/code] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91778&ptid=17831]3#[/url] [i]GBKEE[/i] [/b]
非常謝謝版主!! 可以運作了~^^
另外想請教版主一下
如果每個sheet 第一列直接是資料(沒有姓名、年齡、婚姻)
請問程式碼要怎麼微調? 第一列的資料都會一起帶入此次新增的工作表裡面QQ" [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91779&ptid=17831]4#[/url] [i]Michelle-W[/i] [/b][code] With Sheets("List").UsedRange
For i = 2 To .Rows.Count
[/code]那就從第一列開始[code]
With Sheets("List").UsedRange
For i = 1 To .Rows.Count[/code] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91757&ptid=17831]2#[/url] [i]Michelle-W[/i] [/b]
其實你原本之程式碼稍加調整，
也是可行的：[code]Sub 比對新增()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
Dim rng1 As Range, rng2 As Range, c As Variant, cts As Variant, ct2 As Variant
Set sh1 = Sheets(1) ' 資料
Set sh2 = Sheets(2) ' List
Set sh3 = Sheets(3) ' 此次新增
lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' 資料
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row ' List
Set rng1 = sh1.Range("A1:A" & lr1) ' 資料
Set rng2 = sh2.Range("A1:A" & lr2) ' List
With sh3 ' 此次新增
.Cells.Clear
' .Range("A1") = "姓名"
' .Range("B1") = "年齡"
' .Range("C1") = "婚姻"
.Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
End With
For Each c In rng1 ' 資料
Set cts = rng1.Find(c.Value, , LookIn:=xlValues)
Set ct2 = rng2.Find(c.Value, , LookIn:=xlValues)
' If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
If Not cts Is Nothing And ct2 Is Nothing Then ' List
sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(cts.Row).Value ' 此次新增
End If
Next
End Sub
[/code]GBKEE 版大那兒，你也可以學到不錯的觀念與技巧。 [i=s] 本帖最後由 c_c_lai 於 2016-6-27 06:13 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91779&ptid=17831]4#[/url] [i]Michelle-W[/i] [/b]
[attach]24560[/attach]
附上檔案供你測試。
[attach]24561[/attach]
如果你依然想用原本之宣告[code]If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
.
.
End If [/code]亦可， 其與樓上 (#6) 的[code]If Not cts Is Nothing And ct2 Is Nothing Then
.
.
End If [/code]表述是異曲同工。(省略了 ct2 的變數宣告與給予值 (Assign Value) 的設定 )[code]Sub 比對新增2()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
Dim rng1 As Range, rng2 As Range, c As Variant, cts As Variant
Set sh1 = Sheets(1) ' 資料
Set sh2 = Sheets(2) ' List
Set sh3 = Sheets(3) ' 此次新增
lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' 資料
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row ' List
Set rng1 = sh1.Range("A1:A" & lr1) ' 資料
Set rng2 = sh2.Range("A1:A" & lr2) ' List
With sh3 ' 此次新增
.Cells.Clear
' .Range("A1") = "姓名"
' .Range("B1") = "年齡"
' .Range("C1") = "婚姻"
.Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
End With
For Each c In rng1 ' 資料
Set cts = rng1.Find(c.Value, , LookIn:=xlValues)
If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(cts.Row).Value ' 此次新增
End If
Next
End Sub
[/code]抑或是根本不使用 cts、ct2 的兩個變數宣告與給予值 (Assign Value) 的設定[code]Sub 比對新增3()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long
Dim rng1 As Range, rng2 As Range, c As Variant
Set sh1 = Sheets(1) ' 資料
Set sh2 = Sheets(2) ' List
Set sh3 = Sheets(3) ' 此次新增
lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' 資料
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row ' List
Set rng1 = sh1.Range("A1:A" & lr1) ' 資料
Set rng2 = sh2.Range("A1:A" & lr2) ' List
With sh3 ' 此次新增
.Cells.Clear
' .Range("A1") = "姓名"
' .Range("B1") = "年齡"
' .Range("C1") = "婚姻"
.Range("A1").Resize(, 3) = Split("姓名,年齡,婚姻", ",")
End With
For Each c In rng1 ' 資料
If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
sh3.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = sh1.Rows(c.Row).Value ' 此次新增
End If
Next
End Sub[/code]其結果仍是一致的。
此端視你個人撰寫的經驗、習慣與邏輯思考。
[attach]24562[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=91806&ptid=17831]7#[/url] [i]c_c_lai[/i] [/b]
您修改的程式碼都可以用
因為我是自學的初學者，還看不懂太多
不過我還是會努力搞懂的
真的非常謝謝您們兩位的教導!~~^^ [i=s] 本帖最後由 Andy2483 於 2023-5-25 16:32 編輯 [/i]
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
List資料庫:
[attach]36435[/attach]
資料表(新比對資料):
[attach]36436[/attach]
結果表執行前:
[attach]36437[/attach]
執行結果:
[attach]36438[/attach]
Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j&, T$
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是字典[/color]
Brr = Range([List!C1], [List!A65536].End(xlUp))
[color=SeaGreen]'↑令Brr變數是 二維陣列,以List表A~C欄儲存格值帶入陣列裡[/color]
For i = 2 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3): Y(T) = i
[color=SeaGreen] '↑令以每個迴圈3欄值組成的新字串當key,item是列號,納入Y字典[/color]
Next
Brr = Range([資料!C1], [資料!A65536].End(xlUp))
[color=SeaGreen]'↑令Br陣列,換裝資料表A~C欄儲存格值[/color]
For i = 2 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3)
If Y(T) <> "" Then GoTo i01
[color=SeaGreen] '↑如果以迴圈3欄值組成的新字串查Y字典得item值不是空的,
'就跳到標示i01位置繼續執行[/color]
R = R + 1
[color=SeaGreen] '↑令R變數累加1[/color]
For j = 1 To 3: Brr(R, j) = Brr(i, j): Next
[color=SeaGreen] '↑設順迴圈!將Brr陣列值往上謄,將原陣列值覆蓋[/color]
i01: Next
If R = 0 Then MsgBox "無新增": GoTo i02
[color=SeaGreen]'↑如果R變數是初始值0,就跳到標示i02位置繼續執行[/color]
With Sheets("此次新增")
.UsedRange.Offset(1, 0).Clear
[color=SeaGreen] '↑將結果表有使用儲存格往下偏移1列的範圍清除[/color]
.[A2].Resize(R, 3) = Brr
[color=SeaGreen] '↑令Brr陣列值寫入結果表中,超出範圍的陣列值忽略[/color]
End With
i02: Set Y = Nothing: Erase Brr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub
[color=SeaGreen]=============================================[/color]
補充: 以下是將結果資料謄入另一陣列的方法
Option Explicit
Sub TEST_1()
Dim Brr, Crr, Y, R&, i&, j&, T$
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是字典[/color]
Brr = Range([List!C1], [List!A65536].End(xlUp))
[color=SeaGreen]'↑令Brr變數是 二維陣列,以List表A~C欄儲存格值帶入陣列裡[/color]
For i = 2 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3): Y(T) = i
[color=SeaGreen] '↑令以每個迴圈3欄值組成的新字串當key,item是列號,納入Y字典[/color]
Next
Brr = Range([資料!C1], [資料!A65536].End(xlUp))
[color=SeaGreen]'↑令Br陣列,換裝資料表A~C欄儲存格值[/color]
ReDim Crr(1 To UBound(Brr), 1 To 3)
[color=SeaGreen]'↑宣告Crr變數是 二維空陣列,縱向範圍同Brr,橫向1~3[/color]
For i = 2 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Brr(i, 1) & Brr(i, 2) & Brr(i, 3)
If Y(T) <> "" Then GoTo i01
[color=SeaGreen] '↑如果以迴圈3欄值組成的新字串查Y字典得item值不是空的,
'就跳到標示i01位置繼續執行[/color]
R = R + 1
[color=SeaGreen] '↑令R變數累加1[/color]
For j = 1 To 3: Crr(R, j) = Brr(i, j): Next
[color=SeaGreen] '↑設順迴圈!將Brr陣列值寫入Crr陣列中[/color]
i01: Next
If R = 0 Then MsgBox "無新增": GoTo i02
[color=SeaGreen]'↑如果R變數是初始值0,就跳到標示i02位置繼續執行[/color]
With Sheets("此次新增")
.UsedRange.Offset(1, 0).Clear
[color=SeaGreen] '↑將結果表有使用儲存格往下偏移1列的範圍清除[/color]
.[A2].Resize(R, 3) = Crr
[color=SeaGreen] '↑令Crr陣列值寫入結果表中,超出範圍的陣列值忽略[/color]
End With
i02: Set Y = Nothing: Erase Brr, Crr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub
頁:
[1]