- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-11-28
|
27#
發表於 2024-2-17 14:23
| 只看該作者
本帖最後由 Andy2483 於 2024-2-17 14:28 編輯
回復 26# aassddff736
以 快速比對兩份資料是否一樣(BOM版).zip 範例修改方案如下:
差異結果:
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 |
|
