Option Explicit
Sub Перебор()
PereborRange Columns("A:C"), Columns("E:E"), Columns("G:I"), Columns("K:K")
End Sub
Private Sub PereborRange(ra As Range, rb As Range, printA As Variant, printB As Variant)
Dim aic As Variant
aic = GetAllValueFromRange(ra)
Dim bic As Variant
bic = GetAllValueFromRange(rb)
Dim yp As Long
yp = UBound(aic) + 1
yp = yp * (UBound(bic) + 1)
Dim pra As Variant, prb As Variant
ReDim pra(1 To yp, 1 To UBound(Split(aic(0), "#")) + 1)
ReDim prb(1 To yp, 1 To UBound(Split(bic(0), "#")) + 1)
Dim aa As Variant, bb As Variant, arr As Variant, xp As Long
yp = 0
For Each aa In aic
For Each bb In bic
yp = yp + 1
arr = Split(aa, "#")
For xp = 1 To UBound(arr) + 1
pra(yp, xp) = arr(xp - 1)
Next
arr = Split(bb, "#")
For xp = 1 To UBound(arr) + 1
prb(yp, xp) = arr(xp - 1)
Next
Next
Next
printA.Resize(1, UBound(pra, 2)).EntireColumn.ClearContents
printB.Resize(1, UBound(prb, 2)).EntireColumn.ClearContents
printA.Resize(UBound(pra, 1), UBound(pra, 2)).Value = pra
printB.Resize(UBound(prb, 1), UBound(prb, 2)).Value = prb
End Sub
Private Function GetAllValueFromRange(rr As Range) As Variant
Dim arr As Variant
arr = GetResizedArrayValue(rr)
Dim rowsHasEmpty As Object
Set rowsHasEmpty = CreateObject("Scripting.Dictionary")
Dim ya As Long, xa As Long
For xa = 1 To UBound(arr, 2)
For ya = 1 To UBound(arr, 1)
If IsEmpty(arr(ya, xa)) Then
rowsHasEmpty(ya) = Empty
End If
Next
Next
Dim columnNoEmptyInEmptyRow As Object
Set columnNoEmptyInEmptyRow = CreateObject("Scripting.Dictionary")
Dim vy As Variant
For Each vy In rowsHasEmpty
For xa = 1 To UBound(arr, 2)
If Not IsEmpty(arr(vy, xa)) Then
columnNoEmptyInEmptyRow(xa) = Empty
End If
Next
Next
Dim fixed As Variant, sKey As String, fic As Object
Set fic = CreateObject("Scripting.Dictionary")
For ya = 1 To UBound(arr, 1)
For xa = 1 To UBound(arr, 2)
If Not IsEmpty(arr(ya, xa)) Then
If Not columnNoEmptyInEmptyRow.Exists(xa) Then
GoTo HasFixedColumn
End If
End If
Next
GoTo NextYa
HasFixedColumn:
ReDim fixed(1 To UBound(arr, 2))
For xa = 1 To UBound(arr, 2)
If Not columnNoEmptyInEmptyRow.Exists(xa) Then
fixed(xa) = arr(ya, xa)
End If
Next
sKey = Join(fixed, "#")
fic(sKey) = Empty
NextYa:
Next
Dim eic As Object
Set eic = CreateObject("Scripting.Dictionary")
For ya = 1 To UBound(arr, 1)
fixed = Empty
For xa = 1 To UBound(arr, 2)
If Not IsEmpty(arr(ya, xa)) Then
If columnNoEmptyInEmptyRow.Exists(xa) Then
If IsEmpty(fixed) Then ReDim fixed(1 To UBound(arr, 2))
fixed(xa) = arr(ya, xa)
End If
End If
Next
If Not IsEmpty(fixed) Then
sKey = Join(fixed, "#")
eic(sKey) = Empty
End If
Next
If eic.Count > 0 Then
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim vv As Variant, ww As Variant, emted As Variant, sumed As Variant
For Each vv In fic
For Each ww In eic
fixed = Split(vv, "#")
emted = Split(ww, "#")
sumed = SumArray(fixed, emted)
sKey = Join(sumed, "#")
dic(sKey) = Empty
Next
Next
GetAllValueFromRange = dic.Keys()
Else
GetAllValueFromRange = fic.Keys()
End If
End Function
Private Function SumArray(arr As Variant, brr As Variant) As Variant
Dim srr As Variant, ys As Long
ReDim srr(LBound(arr) To UBound(arr))
For ys = LBound(srr) To UBound(srr)
If arr(ys) <> "" Then
srr(ys) = arr(ys)
ElseIf brr(ys) <> "" Then
srr(ys) = brr(ys)
End If
Next
SumArray = srr
End Function
Private Function GetResizedArrayValue(rr As Range) As Variant
Dim arr As Variant
arr = Intersect(rr, rr.Parent.UsedRange).Value
Dim yMax As Long, ya As Long, xa As Long
For xa = 1 To UBound(arr, 2)
For ya = UBound(arr, 1) To 1 Step -1
If Not IsEmpty(arr(ya, xa)) Then
If yMax < ya Then
yMax = ya
If yMax = UBound(arr, 1) Then GoTo FoundYmax
End If
End If
Next
Next
FoundYmax:
Set rr = rr.Resize(yMax)
If rr.Cells.CountLarge = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
Else
arr = rr.Value
End If
GetResizedArrayValue = arr
End Function
|
