Здравствуйте, уважаемые знатоки. Интересует решение следующей задачи: Есть диапазон ячеек (таблица текстовых значений и числовых с цветовым оформлением). Необходимо, чтобы Excel автоматически копировал этот диапазон подряд вниз со сдвигом нижестоящих ячеек. А общее количество полученных диапазонов управлялось ячейкой (если значение в ней "3", то 3 копии диапазона, если "20", то 20 копий).
Sub CopyA4D6()
Dim rg As Range, c As Range
Set c = Cells(Rows.Count, 1).End(xlUp).Offset(1)
Do While c.Count < [a2]
Set c = Union(c, c.Areas(c.Areas.Count).Cells(1).Offset(3))
Loop
[a4:d6].Copy c
End Sub
Const RANGE_ADDRESS = "A4:D6"
Sub Main()
Dim n As Long
n = Range("A2").Value
Dim r1 As Range
Set r1 = Range(RANGE_ADDRESS)
Dim r2 As Range
Select Case n
Case 0
Case 1
Set r2 = r1
Case Is > 1
Set r2 = r1.Offset(r1.Rows.Count).Resize((n - 1) * r1.Rows.Count)
r2.Insert Shift:=xlDown
Set r2 = r1.Offset(r1.Rows.Count).Resize((n - 1) * r1.Rows.Count)
r1.Copy r2
End Select
DeleteRest r1, r2.Row + r2.Rows.Count
End Sub
Sub DeleteRest(r1 As Range, yBeg As Long)
Dim y As Long
Dim a As Variant
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = r1.Columns(1)
For y = 1 To UBound(a, 1)
dic.Item(a(y, 1)) = 0
Next
With ActiveSheet
y = .Cells(.Rows.Count, 1).End(xlUp).Row
a = .Range(.Cells(1, 1), .Cells(y, 1))
End With
y = yBeg
Do
If y > UBound(a, 1) Then Exit Do
If Not dic.Exists(a(y, 1)) Then Exit Do
y = y + 1
Loop
If yBeg < y Then
Range(Cells(yBeg, 1), Cells(y - 1, r1.Column + r1.Columns.Count - 1)).Delete Shift:=xlUp
End If
End Sub