Option Explicit
Private Const sCOLOR = "65535,5296274,255,49407"
Sub Очистить()
Dim sh As Worksheet: Set sh = ActiveSheet
Dim arr As Variant, brr As Variant, crr As Variant, drr As Variant
InitArrays arr, brr, crr, drr, sh
If IsEmpty(arr) Then Exit Sub
Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
Dim ya As Byte
For ya = 0 To 1
If Not arr(ya) Is Nothing Then
arr(ya).Cells(1, 1).Resize(sh.UsedRange.Rows.Count).ClearContents
End If
Next
Application.Calculation = Application_Calculation
End Sub
Sub Сравнить()
Dim sh As Worksheet: Set sh = ActiveSheet
Dim arr As Variant, brr As Variant, crr As Variant, drr As Variant
InitArrays arr, brr, crr, drr, sh
Dim sLeft As String, sRigh As String
sLeft = arr(2).Cells(2, 2).Value
sRigh = arr(2).Cells(2, 3).Value
Dim ya As Long
ya = LBound(brr(2), 1) - 1
Dim vv As Variant
For Each vv In drr(LBound(brr))
If Not drr(1).Exists(vv) Then
ya = ya + 1
brr(2)(ya, 1) = vv
brr(3)(ya, 1) = sLeft & vv
If ya > 1 Then brr(3)(ya - 1, 1) = brr(3)(ya - 1, 1) & sRigh
End If
Next
If ya = LBound(crr, 1) - 1 Then Exit Sub
For Each vv In Array(2, 3)
crr = brr(vv)
arr(vv).Cells(3, 1).Resize(sh.UsedRange.Rows.Count).Clear
arr(vv).Cells(2, 1).Copy arr(vv).Cells(2, 1).Resize(ya)
arr(vv).Cells(2, 1).Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
Application.Goto arr(vv).Cells(2, 1).Resize(ya, UBound(crr, 2))
Next
End Sub
Private Function GetDic(arr As Variant) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
Dim vv As Variant
For Each vv In arr
If vv <> "" Then
dic(vv) = Empty
End If
Next
Set GetDic = dic
End Function
Private Function GetCellByColor(sh As Worksheet, ByVal iColor As Long) As Range
Dim cl As Range
For Each cl In sh.UsedRange.Cells
If cl.Interior.Color = iColor Then
Set GetCellByColor = cl
Exit Function
End If
Next
End Function
Private Sub InitArrays(arr As Variant, brr As Variant, crr As Variant, drr As Variant, sh As Worksheet)
Dim frr As Variant, vv As Variant, ya As Long
crr = Split(sCOLOR, ",")
ReDim arr(LBound(crr) To UBound(crr)) As Range
ReDim brr(LBound(arr) To UBound(arr))
ReDim drr(LBound(brr) To UBound(brr))
ya = LBound(arr) - 1
For Each vv In crr
ya = ya + 1
Set arr(ya) = GetCellByColor(sh, vv)
If arr(ya) Is Nothing Then Exit Sub
If ya <= 1 Then
brr(ya) = arr(ya).Resize(sh.UsedRange.Rows.Count).Value
Set drr(ya) = GetDic(brr(ya))
Else
ReDim frr(1 To sh.UsedRange.Rows.Count, 1 To 1)
brr(ya) = frr
frr = Empty
End If
If ya = LBound(brr) Then If drr(ya) Is Nothing Then Exit Sub
Next
End Sub
|
