aassddff736

回復 8# Andy2483

Excel比對原始資料222.zip (35.92 KB)

Excel比對原始資料222
下載次數: 1

2024-2-16 19:14

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

aassddff736

回復 8# Andy2483


   我是想增加一頁只留差異部份
★座標比對顏色調整.zip (55.17 KB)

差異
下載次數: 1

2024-2-16 19:23

Andy2483

回復 11# aassddff736

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

下載 (49.59 KB)

2024-2-17 08:13

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

回復 12# aassddff736

Form表:

下載 (57.87 KB)

2024-2-17 08:33

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

回復 13# Andy2483

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





    Excel比對原始資料44.zip (42.85 KB)

下載次數: 1

2024-2-17 09:34

aassddff736

回復 14# Andy2483


快速比對兩份資料是否一樣(BOM版).zip (30.78 KB)

下載次數: 1

2024-2-17 09:57

感恩萬分

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

Andy2483

回復 15# aassddff736
差異表:

下載 (99.05 KB)

2024-2-17 10:10

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

下載 (269.27 KB)

2024-2-17 10:13

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

Andy2483

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

下載 (187.55 KB)

2024-2-17 11:11

回復 19# Andy2483

感恩
幫我看看第一欄資料