Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA Повторить каждую строку нужное кол-во раз
 
#1
07.12.2019 17:41:59
Добрый вечер!
Друзья, подскажите, пожалуйста, как с помощью VBA повторить уникальные строки заданное число раз, например 5.
Файл примера прилагаю.
Заранее спасибо.
Изменено: OblivionR - 07.12.2019 17:51:07
 
 
 
#2
07.12.2019 17:49:55
Ну и где на трех листах в примере надо повторять строки?
 
 
 
#3
07.12.2019 17:51:47
Kuzmich, извините, не тот файл прикрепил. Сейчас заменил.
 
 
 
#4
07.12.2019 18:01:19
Добрый день!
Код
Sub Макрос1()
Dim rng As Range
Dim Chislo As Integer, x As Integer
Set rng = Selection
If rng <> "" Then
    Chislo = CLng(InputBox("Сколько повторений выделенной строки?", "Введите данные", 2))
    For x = 1 To Chislo
        rng.EntireRow.Copy
        rng.EntireRow.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
    Next x
End If
End Sub
 
 
 
#5
07.12.2019 18:08:54
Код
Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = iLastRow To 2 Step -1
      Rows(i + 1).Resize(4).Insert
      Range(Cells(i, "A"), Cells(i, "C")).Resize(5).FillDown
    Next
End Sub
 
 
 
#6
08.12.2019 10:46:36
Dmitriy XM, Kuzmich, спасибо за отклик.
Решение Kuzmich будет конечно оптимальнее, честно никогда не пользовался ressize, хорошее открытие для меня)
 
 
 
#7
08.12.2019 12:52:38
Экзотический вариант  :)
Код
Sub мяу()
    Dim r As Range
    Dim k&, sortNum&
    k = 3
    With ActiveSheet
        Set r = .Range("A1").CurrentRegion
        r.Offset(1).Resize(r.Rows.Count - 1).Copy r(1).Offset(r.Rows.Count).Resize((r.Rows.Count - 1) * k)
        Application.AddCustomList ListArray:=Application.Transpose(r.Columns(1))
        sortNum = Application.CustomListCount
        Set r = .Range("A1").CurrentRegion
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=r(1), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=sortNum, DataOption:=xlSortNormal
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'        Application.DeleteCustomList ListNum:=Application.CustomListCount
        Set r = Nothing
    End With
End Sub
 
 
 
Страницы: 1
Наверх