麻辣家族討論版版 - Powered by Discuz! Board

標題: vba比對兩份資料是否一樣列出差異 [打印本頁]

作者: aassddff736 時間: 2024-2-9 21:40 標題: vba比對兩份資料是否一樣列出差異

個位大神請教一下,我想要比對兩份資料是否一樣,列出差異部份,vba如何做[attach]37410[/attach]

作者: Andy2483 時間: 2024-2-15 13:23

回復 1# aassddff736

謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

Option Explicit
Sub TEST1()
Dim Arr, Brr, Crr, K, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Arr = Range([a資料!F1], [a資料!A65536].End(3)): Brr = Range([b資料!F1], [b資料!A65536].End(3))
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To 2)
For i = 2 To UBound(Arr)
Ta = Trim(Arr(i, 1)): If Ta <> "" Then Z(Ta) = Z(Ta) + 1: Z(Ta & "/Ra") = i: Arr(i, 6) = "": R = R + 1: Crr(R, 1) = Ta: Crr(R, 2) = 1
Next
For i = 2 To UBound(Brr)
Tb = Trim(Brr(i, 1)): If Z(Tb) = 0 Then R = R + 1: Crr(R, 1) = Tb Else Crr(Z(Tb & "/Ra") - 1, 2) = Crr(Z(Tb & "/Ra") - 1, 2) + 1
If Tb <> "" Then Z(Tb) = Z(Tb) + 1: Z(Tb & "/Rb") = i: Brr(i, 6) = ""
Next
For Each K In Z.KEYS
If InStr(K, "/") = 0 And Z(K) = 2 Then N = N + 1: Arr(Z(K & "/Ra"), 6) = N: Brr(Z(K & "/Rb"), 6) = N
Next
Application.Goto [比對結果!A1]
ActiveSheet.UsedRange.Clear: [A:B,H:H].NumberFormatLocal = "@"
With [A2].Resize(R, 2): .Value = Crr: .Sort KEY1:=.Item(2), Order1:=2, Header:=1: [A1] = "NUMBER": End With
With [B1].Resize(UBound(Arr), 6): .Value = Arr: .Sort KEY1:=.Item(6), Order1:=1, Header:=1: Arr = .Value: End With
With [H1].Resize(UBound(Brr), 6): .Value = Brr: .Sort KEY1:=.Item(6), Order1:=1, Header:=1: Brr = .Value: End With
[G:G,M:M].ClearContents: Set xR = ActiveSheet.UsedRange.Offset(N + 1, 1)
For i = 2 To N + 1
For j = 3 To 6: Set xR = IIf(Val(Arr(i, j)) <> Val(Brr(i, j)), Union(xR, Cells(i, j + 1)), xR): Next
Next
Intersect(Union(xR, xR.Offset(, 6)), ActiveSheet.UsedRange).Font.ColorIndex = 3
With Sheets("留下相同")
.UsedRange.Clear: ActiveSheet.UsedRange.Copy .[A1]: .Range(Intersect(xR, ActiveSheet.UsedRange).Address).EntireRow.Delete
End With
With Sheets("留下差異")
.UsedRange.Clear: Intersect(Union([A1], xR), ActiveSheet.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

作者: aassddff736 時間: 2024-2-15 22:27

回復 2# Andy2483
謝謝您的教導
如果我比對資料欄數不固定
比對結果A欄想呈現所有資料,差異標紅色新增標藍色
如何做?

[attach]37416[/attach]

作者: Andy2483 時間: 2024-2-16 10:52

回復 3# aassddff736

以下是欄數不固定,以原排序方式的方案,請前輩參考
Option Explicit
Sub TEST1()
Dim Arr, Brr, Crr, C%, K, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Set Arr = Sheets(1).[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1)): Set Brr = Sheets(2).[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To 2)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): If Ta <> "" Then Z(Ta) = Z(Ta) + 1: Z(Ta & "/Ra") = i: R = R + 1: Crr(R, 1) = Ta: Crr(R, 2) = 1
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): If Z(Tb) = 0 Then R = R + 1: Crr(R, 1) = Tb Else Crr(Z(Tb & "/Ra"), 2) = Crr(Z(Tb & "/Ra"), 2) + 1
If Tb <> "" Then Z(Tb) = Z(Tb) + 1: Z(Tb & "/Rb") = i
Next
For Each K In Z.KEYS
If InStr(K, "/") = 0 And Z(K) = 2 Then N = N + 1: Arr(Z(K & "/Ra"), C) = N: Brr(Z(K & "/Rb"), C) = N
Next
Application.Goto [比對結果!A1]
ActiveSheet.UsedRange.Clear: [A1] = "NUMBER"
With [A2].Resize(R, 2): .Value = Crr: .Sort KEY1:=.Item(2), Order1:=2, Header:=1: .Columns(2).ClearContents: End With
With [B2].Resize(UBound(Arr), C): .Value = Arr: .Sort KEY1:=.Item(C), Order1:=1, Header:=1: Arr = .Value: .Columns(C).ClearContents: End With
With Cells(2, C + 2).Resize(UBound(Brr), C): .Value = Brr: .Sort KEY1:=.Item(C), Order1:=1, Header:=1: Brr = .Value: .Columns(C).ClearContents: End With
[B1] = "New": [B1].Resize(, C - 1).Merge: [B1].Item(, C + 1) = "Old": [B1].Item(, C + 1).Resize(, C - 1).Merge
Set xR = ActiveSheet.UsedRange.Offset(N + 1, 1)
For i = 1 To N
For j = 3 To C: Set xR = IIf(Val(Arr(i, j)) <> Val(Brr(i, j)), Union(xR, Cells(i + 1, j + 1), Cells(i + 1, 2)), xR): Next
Next
Intersect(Union(xR, xR.Offset(, C)), ActiveSheet.UsedRange).Font.ColorIndex = 3
With Sheets("留下相同")
.UsedRange.Clear: ActiveSheet.UsedRange.Copy .[A1]: .Range(Intersect(xR.EntireRow, ActiveSheet.UsedRange).Address).EntireRow.Delete
End With
With Sheets("留下差異")
.UsedRange.Clear: Intersect(Union([A1], xR.EntireRow), ActiveSheet.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

作者: aassddff736 時間: 2024-2-16 13:04

回復 4# Andy2483

感謝大神指教
這個好像是同列比對我想要的是只要資料相同是為一樣不管順序
比對結果A,B,J欄位置要一樣

作者: aassddff736 時間: 2024-2-16 13:20

回復 4# Andy2483

[attach]37418[/attach]
能幫我看看這個檔案
我想要增加一頁只秀差異部分比對結果new,old 間留一行空白比較沒這麼亂

作者: Andy2483 時間: 2024-2-16 13:47

本帖最後由 Andy2483 於 2024-2-16 14:52 編輯

回復 5# aassddff736

比對結果A,B,J欄位置一樣的方案,請前輩參考

Option Explicit
Sub TEST2()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("比對結果")
Set Arr = Sheets(1).[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets(2).[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
xS.UsedRange.Clear: [A1] = "NUMBER"
With [A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(2), Order1:=1, Header:=2: Crr = .Value: End With
[B1] = "New": [B1].Resize(, C - 1).Merge: [B1].Item(, C + 1) = "Old": [B1].Item(, C + 1).Resize(, C - 1).Merge
Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, Cells(i, j), Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
With Sheets("留下相同")
.UsedRange.Clear: xS.UsedRange.Copy .[A1]
.Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("留下差異")
.UsedRange.Clear: Intersect(Union([A1], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

作者: Andy2483 時間: 2024-2-16 15:02

回復 6# aassddff736

只秀差異部分比對結果new,old 間留一行空白方案如下,請前輩參考
Option Explicit
Sub TEST2()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("Result")
Set Arr = Sheets(2).[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets(3).[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
xS.UsedRange.Clear: [A1] = "NUMBER"
With [A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(2), Order1:=1, Header:=1: Crr = .Value: End With
[B1] = "New": [B1].Resize(, C - 1).Merge: [B1].Item(, C + 1) = "Old": [B1].Item(, C + 1).Resize(, C - 1).Merge
Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, Cells(i, j), Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
End Sub

作者: aassddff736 時間: 2024-2-16 17:18

回復 7# Andy2483

可以了也謝謝大神
能依照A欄排序嗎?

作者: Andy2483 時間: 2024-2-16 17:54

回復 9# aassddff736

.Sort KEY1:=.Item(2) 改為 .Sort KEY1:=.Item(1)

作者: aassddff736 時間: 2024-2-16 19:15

回復 8# Andy2483

[attach]37422[/attach]
謝謝大神! 萬分感恩!
能依照A欄排序且自動調整欄寬嗎?
還有我想要給資料A,B名稱另存差異記錄如何做?

作者: aassddff736 時間: 2024-2-16 19:23

回復 8# Andy2483

我是想增加一頁只留差異部份
[attach]37423[/attach]

作者: Andy2483 時間: 2024-2-17 08:14

回復 11# aassddff736

依照A欄排序,自動調整欄寬,依資料A,B對照名稱為標列,另存差異記錄須自己存檔方案如下:
設定表:
[attach]37424[/attach]

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("比對結果")
Set Arr = Sheets("資料A").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets("資料B").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B6:B8] = "": [B9] = 0: [B10] = 0: MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=2: Crr = .Value: End With
xS.[B1] = [設定!B2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Item(, C + 1) = [設定!B3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge
xS.UsedRange.EntireColumn.AutoFit: Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
With Sheets("留下相同")
.UsedRange.EntireRow.Delete: xS.UsedRange.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
.Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("留下差異")
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
End With
[B6] = C - 1: [B7] = UBound(Arr): [B8] = UBound(Brr): [B9] = 1: [B10] = 1
End Sub

Private Sub CommandButton2_Click()
Sheets("資料A").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("資料B").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("比對結果").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("留下相同").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("留下差異").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
End Sub

Private Sub CommandButton3_Click()
Sheets("資料A").UsedRange.EntireRow.Interior.ColorIndex = 6 'Delete
Sheets("資料B").UsedRange.EntireRow.Interior.ColorIndex = 6 'Delete
End Sub

Private Sub CommandButton4_Click()
Sheets("留下差異").Copy
End Sub

作者: Andy2483 時間: 2024-2-17 08:34

回復 12# aassddff736

Form表:
[attach]37425[/attach]

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("Result")
Set Arr = Sheets("NEW BOM").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets("OLD BOM").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B1:B2] = "": MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=1: Crr = .Value: End With
xS.[B1] = [Form!A2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Item(, C + 1) = [Form!A3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge
xS.UsedRange.EntireColumn.AutoFit: Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
With Sheets("差異")
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1:A2], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
End With
[B1] = C - 1: [B2] = UBound(Arr): [B3] = UBound(Brr)
End Sub

作者: aassddff736 時間: 2024-2-17 09:35

回復 13# Andy2483

感謝大神執行有一點問題可以幫我看看嗎?
另存差異名稱可以是"Sheets(1).[B2] & Sheets(1).[B3] 差異"
Sheets("比對結果")("留下相同")("留下差異")[B1]想跨欄置中填色

[attach]37426[/attach]

作者: aassddff736 時間: 2024-2-17 10:06

回復 14# Andy2483

[attach]37428[/attach]

感恩萬分

這個檔案我想
1.new,old 間留一行空
2.自動換行
3.加上差異頁

作者: Andy2483 時間: 2024-2-17 10:12

回復 15# aassddff736
差異表:
[attach]37429[/attach]

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("比對結果")
Set Arr = Sheets("資料A").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets("資料B").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B6:B8] = "": [B9] = 0: [B10] = 0: MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=2: Crr = .Value: End With
xS.[B1] = [B2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Interior.Color = [B2].Interior.Color
xS.[B1].Item(, C + 1) = [B3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge: xS.[B1].Item(, C + 1).Interior.Color = [B3].Interior.Color
xS.UsedRange.EntireColumn.AutoFit: Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
With Sheets("留下相同")
.UsedRange.EntireRow.Delete: xS.UsedRange.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
.Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("留下差異")
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
End With
[B6] = C - 1: [B7] = UBound(Arr): [B8] = UBound(Brr): [B9] = 1: [B10] = 1
End Sub
'===================================================
Private Sub CommandButton4_Click()
Dim Snm$
Snm = [B2] & "&" & [B3] & "_差異"
Sheets("留下差異").Copy
ActiveSheet.Name = Snm
End Sub

作者: aassddff736 時間: 2024-2-17 10:17

[attach]37430[/attach]回復 14# Andy2483
感謝大神已經很接近我想要的了
但是有時我的資料是BOM 想標示部分差異

作者: Andy2483 時間: 2024-2-17 10:53

回復 Andy2483

感恩萬分

這個檔案我想
1.new,old 間留一行空
2.自動換行
3.加上差異頁
aassddff736 發表於 2024-2-17 10:06

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("Result")
Set Arr = Sheets("NEW BOM").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets("OLD BOM").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B1:B2] = "": MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
Sheets("NEW BOM").UsedRange.EntireColumn.Copy xS.[B1]: Sheets("OLD BOM").UsedRange.EntireColumn.Copy xS.[B1].Offset(, C)
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=1: Crr = .Value: End With
xS.[B1] = [A2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Item(, C + 1) = [A3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge
Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter: xS.UsedRange.EntireRow.WrapText = True
For i = 2 To R + 1
For j = 3 To C
Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
xB.EntireRow.Font.ColorIndex = 5
With Sheets("差異")
xS.UsedRange.EntireColumn.Copy .[A1]
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1:A2], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
End With
[B1] = C - 1: [B2] = UBound(Arr): [B3] = UBound(Brr)
End Sub

作者: aassddff736 時間: 2024-2-17 11:13

[attach]37431[/attach]回復 19# Andy2483

感恩
幫我看看第一欄資料

作者: aassddff736 時間: 2024-2-17 11:16

回復 17# Andy2483

感謝大神
這個清除資料會變填色

作者: Andy2483 時間: 2024-2-17 11:35

回復 21# aassddff736

Sheets("資料A").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("資料A").UsedRange.EntireRow.Delete

作者: aassddff736 時間: 2024-2-17 12:29

回復 22# Andy2483
感謝指導
我是VBA小白
可以直接些資料給我複製嗎?

作者: Andy2483 時間: 2024-2-17 12:56

回復 23# aassddff736

Sheets("資料A").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
'↑令工作表"資料A" 有使用儲存格所在的整列底色為淡黃色

Sheets("資料A").UsedRange.EntireRow.Delete
'↑令工作表"資料A" 有使用儲存格所在的整列刪除

作者: aassddff736 時間: 2024-2-17 12:57

回復 24# Andy2483

可以了
真的非常謝謝您

作者: aassddff736 時間: 2024-2-17 13:11

回復 19# Andy2483

著個我是要比對BOM用
可以只將內容部分差異標色起來嗎?[attach]37434[/attach]

作者: Andy2483 時間: 2024-2-17 14:23

本帖最後由 Andy2483 於 2024-2-17 14:28 編輯

回復 26# aassddff736

以  快速比對兩份資料是否一樣(BOM版).zip 範例修改方案如下:
差異結果:
[attach]37435[/attach]

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, A, B, D, Z, N&, K, i&, j%, L%, R&, T$, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("Result")
Set Arr = Sheets("NEW BOM").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
Set Brr = Sheets("OLD BOM").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B1:B2] = "": MsgBox "欄數不同": Exit Sub
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
For i = 1 To UBound(Arr)
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
Next
For i = 1 To UBound(Brr)
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
Next
Application.Goto xS.[A1]
Sheets("NEW BOM").UsedRange.EntireColumn.Copy xS.[B1]: Sheets("OLD BOM").UsedRange.EntireColumn.Copy xS.[B1].Offset(, C)
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=1: Crr = .Value: End With
xS.[B1] = [A2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Item(, C + 1) = [A3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge
Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter: xS.UsedRange.EntireRow.WrapText = True
For i = 2 To R + 1
For j = 3 To C
   Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
   If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
For Each A In xR
If InStr(A, ",") And InStr(A.Item(1, C + 1), ",") Then
   Z.RemoveAll: B = Split(A, ","): D = Split(A.Item(1, C + 1), ",")
   For i = 0 To UBound(B): T = B(i): Z(T) = "B": Next
   For i = 0 To UBound(D): T = D(i): Z(D(i)) = Z(D(i)) & "D": Next
   A.Font.ColorIndex = 1: A.Item(1, C + 1).Font.ColorIndex = 1
   For Each K In Z.KEYS
      If Not Z(K) Like "BD*" Then
         j = InStr(A, K): L = Len(K): If j <> 0 Then A.Characters(Start:=j, Length:=L).Font.ColorIndex = 3
         j = InStr(A.Item(1, C + 1), K): L = Len(K): If j <> 0 Then A.Item(1, C + 1).Characters(Start:=j, Length:=L).Font.ColorIndex = 3
      End If
   Next
End If
Next
xB.EntireRow.Font.ColorIndex = 5
With Sheets("差異")
xS.UsedRange.EntireColumn.Copy .[A1]
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1:A2], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
End With
[B1] = C - 1: [B2] = UBound(Arr): [B3] = UBound(Brr)
End Sub

作者: aassddff736 時間: 2024-2-17 14:37

[attach]37436[/attach]回復 27# Andy2483
感謝大神
比對結果有一點錯誤

作者: aassddff736 時間: 2024-2-17 14:42

回復 17# Andy2483

請問大神
我想另存差異表在開啟當案的地方或著預設路徑資料夾
如何修改

作者: Andy2483 時間: 2024-2-17 14:50

回復 28# aassddff736

以 16#樓快速比對兩份資料是否一樣(BOM版).zip 範例修改執行沒問題
如果一直改範例,建議自己學會修改VBA

作者: Andy2483 時間: 2024-2-17 14:51

回復 29# aassddff736

另存檔情境多變化,建議手動另存

作者: aassddff736 時間: 2024-2-17 14:57

回復 17# Andy2483

[attach]37437[/attach]

請問大神
Sheet1名稱有碼數限制
我想另存差異表在開啟當案的地方或著預設路徑資料夾
如何修改

作者: Andy2483 時間: 2024-2-17 15:02

回復 32# aassddff736

讓新工作表名不要違反此規則

作者: aassddff736 時間: 2024-2-17 15:42

回復 30# Andy2483

謝謝指導! 真的很是感謝您幫忙解答
我有買書自習但是還是小白

作者: aassddff736 時間: 2024-2-18 01:26

回復 13# Andy2483
哈嘍大神可以幫我看看
為什麼我比對資料只有一行時差異資料沒秀出來
[attach]37438[/attach]

作者: Andy2483 時間: 2024-2-19 08:30

回復 35# aassddff736

將 For j = 3 To C 改為 For j = 2 To C

作者: aassddff736 時間: 2024-2-19 10:38

回復 10# Andy2483
早安!大神
我改這個 Sort KEY1:=.Item(1) 一樣"留下差異"沒資料
[attach]37444[/attach]

作者: aassddff736 時間: 2024-2-19 11:40

回復 36# Andy2483

謝謝大神

不好意思看錯回復
這個更改後For j = 2 To C 可以了

非常非常高興謝謝大神的幫忙

作者: Andy2483 時間: 2024-2-21 09:04

回復 38# aassddff736

謝謝論壇,謝謝前輩上論壇一起學習
後學複習了一下並作註解,貼上來請前輩參考,請各位前輩指教

Option Explicit
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, C%, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range, xB As Range, xS As Worksheet
'↑宣告變數,%是短整數,&是長整數,$是字串變數,As Range是儲存格變數,As Worksheet是工作表變數,其它沒有指定的是通用型變數
Set Z = CreateObject("Scripting.Dictionary"): Set xS = Sheets("比對結果")
'↑令Z變數是字典,令xS變數是工作表("比對結果")
Set Arr = Sheets("資料A").[A1].CurrentRegion: Arr = Union(Arr, Arr.Offset(, 1))
'↑令Arr變數是工作表("資料A").[A1]儲存格相鄰串聯後擴展成的最小方正區域儲存格
'令Arr變數變身為二維陣列 (聯集自身區域往右偏移1欄後的區域儲存格值帶入陣列中)
Set Brr = Sheets("資料B").[A1].CurrentRegion: Brr = Union(Brr, Brr.Offset(, 1))
'↑令Brr變數是工作表("資料A").[A1]儲存格相鄰串聯後擴展成的最小方正區域儲存格
'令Brr變數變身為二維陣列 (聯集自身區域往右偏移1欄後的區域儲存格值帶入陣列中)
C = UBound(Arr, 2): If C <> UBound(Brr, 2) Then [B6:B8] = "": [B9] = 0: [B10] = 0: MsgBox "欄數不同": Exit Sub
'↑令C變數是Arr陣列最大索引欄號
'如果C變數不同於Brr陣列最大索引欄號!就令[B6:B8]儲存格值是空字元:令[B9]是0,令[B10]是0,最後跳出提視窗~~~,結束程式執行
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To C * 2 + 1)
'↑宣告Crr變數是二維陣列,縱向範圍從1 到(Arr陣列縱向最大索引列號+Brr陣列縱向最大索引列號),橫向範圍從1 到(C變數*2+1)
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1 到Arr陣列縱向最大索引列號
Ta = Trim(Arr(i, 1)): R = R + 1: Z(Ta) = R: Crr(R, 1) = Ta
'↑令Ta這字串變數是 i迴圈列1欄Arr陣列值去除頭尾空白字元後的新字串,令R變數累加1
'令以Ta變數為key,R變數為item納入Z字典中:令R變數列1欄Crr陣列值是 Ta變數
For j = 1 To C: Crr(R, j + 1) = Arr(i, j): Next
'↑設順迴圈!j從1 到變數C: 令R變數列(j+1)欄Crr陣列值是 i迴圈列j迴圈欄Arr陣列值
Next
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1 到Brr陣列縱向最大索引列號
Tb = Trim(Brr(i, 1)): N = Z(Tb): If N = 0 Then R = R + 1: Crr(R, 1) = Tb: N = R: Z(Tb) = R
'↑令Tb這字串變數是 i迴圈列1欄Brr陣列值去除頭尾空白字元後的新字串,令N這長整數變數是以Tb變數為key查Z字典回傳值(item)
'如果N變數是 0,就令R變數累加1:令R變數列1欄Crr陣列值是 Tb變數,令N變數=R變數,令以Tb變數為key,R變數為item納入Z字典中
For j = 1 To C: Crr(N, j + 1 + C) = Brr(i, j): Next
'↑設順迴圈!j從1 到變數C: 令N變數列(j+1+C)欄Crr陣列值是 i迴圈列j迴圈欄Brr陣列值
Next
Application.Goto xS.[A1]
'↑令游標跳到xS變數的[A1]儲存格位置
xS.UsedRange.EntireRow.Delete: xS.[A1] = "NUMBER"
'↑令xS變數裡有使用儲存格所在的列刪除,令xS變數的[A1]儲存格值是字串 "NUMBER"
With xS.[A2].Resize(R, C * 2 + 1): .Value = Crr: .Sort KEY1:=.Item(1), Order1:=1, Header:=2: Crr = .Value: End With
'↑令xS變數裡[A2]儲存格擴展剛好的區域以Crr陣列值帶入,並令以該區域儲存格以第1欄為基準做沒有標題列的順排序
xS.[B1] = [B2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Interior.Color = [B2].Interior.Color
'↑令xS變數裡[B1]儲存格值同本表[B2]儲存格值,令標題列儲存格合併,令該標題列儲存格底色同本表[B2]儲存格底色
xS.[B1].Item(, C + 1) = [B3]: xS.[B1].Item(, C + 1).Resize(, C - 1).Merge: xS.[B1].Item(, C + 1).Interior.Color = [B3].Interior.Color
'↑令xS變數裡[B1]自身開始往右C+1欄儲存格值同本表[B3]儲存格值
'令標題列儲存格合併,令該標題列儲存格底色同本表[B3]儲存格底色
xS.UsedRange.EntireColumn.AutoFit: Set xR = xS.UsedRange: Set xR = xR(xR.Count + 1): Set xB = xR: xS.[1:1].HorizontalAlignment = xlCenter
'↑令xS變數裡有使用儲存格所在欄位自動調整欄寬,令xR變數是 xS變數裡有使用儲存格: 令xR變數是沒使用的地1個儲存格
'令xB變數是同xR變數(儲存格):令xS變數裡第1列儲存格格式水平文字置中
For i = 2 To R + 1
'↑設順迴圈!i從2 到R變數+1
For j = 2 To C
'↑設順迴圈!j從2 到C變數
   Set xR = IIf(Crr(i - 1, j) <> Crr(i - 1, j + C), Union(xR, xS.Cells(i, j), xS.Cells(i, 1)), xR)
   '↑令兩區域相對欄位儲存格值如果不同!就將左區儲存格與A欄儲存格納入xR變數中
   If Crr(i - 1, j) = "" Or Crr(i - 1, j + C) = "" Then Set xB = Union(xB, xS.Cells(i, j))
   '↑令兩區域相對欄位儲存格值如果是空格!就將左區儲存格納入xB變數中
Next
Next
Union(xR, xR.Offset(, C)).Font.ColorIndex = 3
'↑令兩區域比對出不同的儲存格連同A欄儲存格xR變數字色變為紅色
xB.EntireRow.Font.ColorIndex = 5
'↑令xB變數所在列整列字色變為藍色
With Sheets("留下相同")
'↑以下是關於工作表("留下相同")的程序
.UsedRange.EntireRow.Delete: xS.UsedRange.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
'↑令該表有使用儲存格所在的整列刪除: 令xS變數有使用儲存格複製到該表[A1]: 令該表有使用儲存格所在欄自動調整欄寬
.Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
'↑令有差異的列整列刪除
End With
With Sheets("留下差異")
'↑以下是關於工作表("留下差異")的程序
.UsedRange.EntireRow.Delete: Intersect(Union(xS.[A1], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
'↑令該表有使用儲存格所在的整列刪除: 令xS變數有差異的列整列複製到該表[A1]: 令該表有使用儲存格所在欄自動調整欄寬
End With
[B6] = C - 1: [B7] = UBound(Arr): [B8] = UBound(Brr): [B9] = 1: [B10] = 1
'↑令本表[B6]值是 C變數-1: 令[B7]值是Arr陣列縱向最大索引列號: 令[B8]值是Brr陣列縱向最大索引列號
End Sub

作者: aassddff736 時間: 2024-2-23 14:33

謝謝還這麼用心、詳細的註解，還有附加說明，感謝。
此讓學生學習了很多，更清楚的了解用法。

作者: ianlcc 時間: 2024-3-5 09:48

謝謝分享！
學習很多，尤其andy還幫忙寫了註解

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