Option Explicit
Sub АргентинаЯмайка()
Dim dic As Object
Set dic = GetDic()
If dic.Count > 0 Then
Dim ar1 As Variant
Dim ar2 As Variant
CompareTb dic, ar1, ar2, True
CompareTb dic, ar1, ar2, False
End If
Dim rOut As Range
Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
OutArr ar1, rOut
OutArr ar2, rOut.Cells(1, 5)
End Sub
Sub OutArr(arr As Variant, rOut As Range)
With rOut.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2))
.NumberFormat = "@"
.Cells = arr
.EntireColumn.AutoFit
End With
rOut.Parent.Parent.Saved = True
End Sub
Function CompareTb(dic As Object, ByRef arrIn1 As Variant, ByRef arrIn2 As Variant, compareMod As Boolean) As Boolean
Dim arr As Variant
'ReDim arr(1 To 3 * (dic.Count * (dic.Count - 1)), 1 To 3)
ReDim arr(1 To 2, 1 To 3)
Dim ar2 As Variant
'ReDim ar2(1 To 3 * (dic.Count * (dic.Count - 1)), 1 To 3)
ReDim ar2(1 To 1, 1 To 3)
Dim col1 As New Collection
Dim col2 As New Collection
Dim u As Long
Dim i As Long
Dim j As Long
Dim w As Long
Dim y As Long
Dim x As Byte
Dim irr As Variant
Dim jrr As Variant
Dim f As Boolean
Dim atLeastOne As Boolean
For i = 0 To dic.Count - 2
irr = dic.Items()(i)
atLeastOne = False
For j = IIf(compareMod, i + 1, 0) To dic.Count - 1
If i <> j Then
jrr = dic.Items()(j)
If UBound(irr, 1) = UBound(jrr, 1) Then
f = True
For y = 2 To UBound(irr, 1)
For x = 1 To UBound(irr, 2)
If irr(y, x) <> jrr(y, x) Then
f = False
Exit For
End If
Next
If Not f Then Exit For
Next
If f Then
u = u + 3
For x = 1 To UBound(irr, 2)
'arr(u + 0, x) = irr(1, x)
'arr(u + 1, x) = jrr(1, x)
arr(1, x) = irr(1, x)
arr(2, x) = jrr(1, x)
Next
col1.Add arr
atLeastOne = True
End If
End If
End If
Next
If atLeastOne = False Then
w = w + 3
For x = 1 To UBound(irr, 2)
'ar2(w, x) = irr(1, x)
ar2(1, x) = irr(1, x)
Next
col2.Add ar2
End If
Next
If compareMod Then
u = u + 1
If u > Application.Rows.Count Then u = Application.Rows.Count
Dim brr As Variant
ReDim brr(1 To u, 1 To 3)
' For y = 1 To UBound(brr, 1)
' For x = 1 To 3
' brr(y, x) = arr(y, x)
' Next
' Next
y = 1
For Each arr In col1
For x = 1 To 3
brr(y + 0, x) = arr(1, x)
brr(y + 1, x) = arr(2, x)
Next
y = y + 3
Next
arrIn1 = brr
Else
w = w + 1
If w > Application.Rows.Count Then w = Application.Rows.Count
ReDim brr(1 To w, 1 To 3)
' For y = 1 To UBound(brr, 1)
' For x = 1 To 3
' brr(y, x) = ar2(y, x)
' Next
' Next
y = 1
For Each arr In col2
For x = 1 To 3
brr(y, x) = arr(1, x)
Next
y = y + 2
Next
arrIn2 = brr
End If
CompareTb = True
End Function
Function GetDic() As Object
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
Dim arr As Variant
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y + 1, 1))
Dim b As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 3 To UBound(arr, 1)
If IsEmpty(arr(y, 1)) Then
If b > 0 Then
dic.Item(dic.Count) = .Range(.Cells(b, 1), .Cells(y - 1, 3))
b = 0
End If
Else
If Mid(arr(y, 1), 3, 1) = "-" Then
If b > 0 Then
dic.Item(dic.Count) = .Range(.Cells(b, 1), .Cells(y - 1, 3))
End If
b = y
End If
End If
Next
End With
Set GetDic = dic
End Function
|
В случае, конечно, если он согласен.