Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Создание определённого числа копий диапазона ячеек
 
Здравствуйте, уважаемые знатоки. Интересует решение следующей задачи:
Есть диапазон ячеек (таблица текстовых значений и числовых с цветовым оформлением).
Необходимо, чтобы Excel автоматически копировал этот диапазон подряд вниз со сдвигом нижестоящих ячеек. А общее количество полученных диапазонов управлялось ячейкой (если значение в ней "3", то 3 копии диапазона, если "20", то 20 копий).  
Изменено: PEREPUZO - 14 Янв 2020 05:17:48
 
Код
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
 
Спасибо за помощь:)  
Страницы: 1
Читают тему (гостей: 1)
Наверх