Добрый вечер! Друзья, подскажите, пожалуйста, как с помощью VBA повторить уникальные строки заданное число раз, например 5. Файл примера прилагаю. Заранее спасибо.
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
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
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