Andy2483

¦^´_ 1# aassddff736


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

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 [¤ñ¹ïµ²ªG!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("¯d¤U¬Û¦P")
   .UsedRange.Clear: ActiveSheet.UsedRange.Copy .[A1]: .Range(Intersect(xR, ActiveSheet.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .UsedRange.Clear: Intersect(Union([A1], xR), ActiveSheet.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

Andy2483

¦^´_ 3# aassddff736

¥H¤U¬OÄæ¼Æ¤£©T©w,¥H­ì±Æ§Ç¤è¦¡ªº¤è®×,½Ð«e½ú°Ñ¦Ò
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 [¤ñ¹ïµ²ªG!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("¯d¤U¬Û¦P")
   .UsedRange.Clear: ActiveSheet.UsedRange.Copy .[A1]:   .Range(Intersect(xR.EntireRow, ActiveSheet.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .UsedRange.Clear: Intersect(Union([A1], xR.EntireRow), ActiveSheet.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

Andy2483

¦^´_ 5# aassddff736

¤ñ¹ïµ²ªGA,B,JÄæ¦ì¸m¤@¼Ëªº¤è®×,½Ð«e½ú°Ñ¦Ò

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("¤ñ¹ïµ²ªG")
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 "Äæ¼Æ¤£¦P": 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("¯d¤U¬Û¦P")
   .UsedRange.Clear: xS.UsedRange.Copy .[A1]
   .Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .UsedRange.Clear: Intersect(Union([A1], xR.EntireRow), xS.UsedRange).EntireRow.Copy .[A1]
End With
End Sub

Andy2483

¦^´_ 6# aassddff736

¥u¨q®t²§³¡¤À ¤ñ¹ïµ²ªGnew,old ¶¡¯d¤@¦æªÅ¥Õ ¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
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 "Äæ¼Æ¤£¦P": 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

Andy2483

¦^´_ 9# aassddff736


    .Sort KEY1:=.Item(2) §ï¬° .Sort KEY1:=.Item(1)

Andy2483

¦^´_ 11# aassddff736

¨Ì·ÓAÄæ±Æ§Ç,¦Û°Ê½Õ¾ãÄæ¼e,¨Ì¸ê®ÆA,B¹ï·Ó¦WºÙ¬°¼Ð¦C,¥t¦s®t²§°O¿ý¶·¦Û¤v¦sÀÉ ¤è®×¦p¤U:
³]©wªí:

¤U¸ü (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("¤ñ¹ïµ²ªG")
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 "Äæ¼Æ¤£¦P": 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] = [³]©w!B2]: xS.[B1].Resize(, C - 1).Merge: xS.[B1].Item(, C + 1) = [³]©w!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("¯d¤U¬Û¦P")
   .UsedRange.EntireRow.Delete: xS.UsedRange.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
   .Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .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("¤ñ¹ïµ²ªG").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("¯d¤U¬Û¦P").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("¯d¤U®t²§").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("¯d¤U®t²§").Copy
End Sub

Andy2483

¦^´_ 12# aassddff736

Formªí:

¤U¸ü (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 "Äæ¼Æ¤£¦P": 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("®t²§")
   .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

Andy2483

¦^´_ 15# aassddff736
®t²§ªí:

¤U¸ü (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("¤ñ¹ïµ²ªG")
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 "Äæ¼Æ¤£¦P": 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("¯d¤U¬Û¦P")
   .UsedRange.EntireRow.Delete: xS.UsedRange.Copy .[A1]: .UsedRange.EntireColumn.AutoFit
   .Range(Intersect(xR.EntireRow, xS.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .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] & "_®t²§"
Sheets("¯d¤U®t²§").Copy
ActiveSheet.Name = Snm
End Sub

Andy2483

¦^´_  Andy2483

·P®¦¸U¤À

³o­ÓÀɮקڷQ
1.new,old ¶¡¯d¤@¦æªÅ
2.¦Û°Ê´«¦æ
3.¥[¤W®t²§­¶
aassddff736 µoªí©ó 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 "Äæ¼Æ¤£¦P": 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("®t²§")
   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

Andy2483

¦^´_ 21# aassddff736

Sheets("¸ê®ÆA").UsedRange.EntireRow.Interior.ColorIndex = 36 'Delete
Sheets("¸ê®ÆA").UsedRange.EntireRow.Delete