Sub d()
Dim a(), b(), c(), ax(), ay(), az()
Dim full(), i&, ii&, iii&, t&
Dim x&, y&, z&
'задаем массивы
With Sheets("Источник")
i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
x = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
a = Range(.Cells(2, 1), .Cells(i, x)).Value
ax = Range(.Cells(1, 1), .Cells(2, x)).Value
End With
With Sheets("Источник 2")
i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
y = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
b = Range(.Cells(2, 1), .Cells(i, x)).Value
ay = Range(.Cells(1, 1), .Cells(2, y)).Value
End With
With Sheets("Источник 3")
i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
z = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
c = Range(.Cells(2, 1), .Cells(i, z)).Value
az = Range(.Cells(1, 1), .Cells(2, z)).Value
End With
ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To x + y + z)
For i = 1 To UBound(a)
For ii = 1 To UBound(b)
For iii = 1 To UBound(c)
t = t + 1
Count = 1
'заполняем элементы массива
For g = 1 To x: full(t, Count) = a(i, g): Count = Count + 1: Next g
For g = 1 To y: full(t, Count) = b(ii, g): Count = Count + 1: Next g
For g = 1 To z: full(t, Count) = c(iii, g): Count = Count + 1: Next g
Next iii, ii, i
Sheets.Add
With Sheets(1)
.Activate
.Cells(1, 1).Resize(UBound(ax), UBound(ax, 2)) = ax
.Cells(1, 1 + x).Resize(UBound(ay), UBound(ay, 2)) = ay
.Cells(1, 1 + x + y).Resize(UBound(az), UBound(az, 2)) = az
.Cells(2, 1).Resize(UBound(full), UBound(full, 2)) = full
End With
End Sub |