Макрос для вставки строк с текстом

[blackeangel]

В общем помогите написать код для вставки 2 строк от первой до последней на листе с учетом имеющейся в них фразах.Например,если в строке по всем столбцам есть слово Олень,то мы вставляем 2 строки над этой строкой,если нет,то пропускаем или (что лучше) ищем по другому условию. Заполняются они в самом коде либо как вариант копируются с другого листа. Количество строк - столько сколько поддерживает эксель(точнее более 180000)
Копируется одно и тоже, но разное количество строк.
Вот начал писать через копи паст с другого листа,но копирует только 1 значение и один раз,что опять не по циклу.

Код: Выделить всё

Sub Insert_Rows()
    Dim lLastRow As Long, li As Long, i As Range ' переменные
    Application.ScreenUpdating = 0 'заморозим экран от изменений
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 'переменной присваиваетс¤ последн¤¤ строка
    For li = lLastRow To 1 Step -1 'ѕ≈–≈Ѕ»–ј≈ћ — последней до первой строки с шагом -1
    Sheets("Ћист2").Select
    ActiveCell.Rows("1:2").EntireRow.Select
    Selection.Copy
    Sheets("Ћист1").Select
    ActiveCell.Rows().EntireRow.Select
    Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Next li
    Application.ScreenUpdating = 1 'разморозили экран и он обновилс¤
End Sub

но тут не работает поиск,он ищет только первое значение и вставляет пустые строки.

Код: Выделить всё

' это вставка двух строк при нахождении фразы,но в выделенной ¤чейке
Sub StrokaAfterSumm()
Attribute StrokaAfterSumm.VB_ProcData.VB_Invoke_Func = "f\n14"
Dim i As Range
Application.ScreenUpdating = 0
  For Each i In Selection
    If i = "3311св" Then i.Offset(-1, 0).EntireRow.Resize(2).Insert xlDown
  Next
  Application.ScreenUpdating = 1
End Sub
' Ёто вставка 2 строк до
Sub Insert_Rows()
Attribute Insert_Rows.VB_ProcData.VB_Invoke_Func = "ф\n14"
    Dim lLastRow As Long, li As Long, i As Range ' переменные
    Application.ScreenUpdating = 0 'заморозим экран от изменений
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 'переменной присваиваетс¤ последн¤¤ строка
    For li = lLastRow To 1 Step -1 'ѕ≈–≈Ѕ»–ј≈ћ — последней до первой строки с шагом -1
'поиск и добавление строк, в for не работает -->
    Cells.Find(What:="3311св", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
  '  Cells.FindNext(After:=ActiveCell).Activate
'   Cells.Find(What:="3311св", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Offset(-1, 0).EntireRow.Resize(2).Insert xlDown
'<--
     '  Rows(li).Resize(2).Insert 'добавл¤ем 2 строки до нужной нам
' если заменить Resize(2) на Resize(1) то будет вставл¤тьс¤ только одна строка
    Next li
    Application.ScreenUpdating = 1 'разморозили экран и он обновилс¤
End Sub
' это вставка двух строк при нахождении фразы,но в выделенной ¤чейке
Sub StrokaAfterSumm2()
Dim i As Range
Application.ScreenUpdating = 0
 ' For Each i In ActiveWorkbook.Worksheets
  Range("A:A").Find("3311св").Offset(-1, 0).EntireRow.Resize(2).Insert xlDown
   'If i = "3311св" Then i.Offset(-1, 0).EntireRow.Resize(2).Insert xlDown
  'Next i
  Application.ScreenUpdating = 1
End Sub

Файл прилагаю.

[pashulka]

Два примера поиска "3311св" в столбце [B:B] с последующей вставкой двух строк.

Код: Выделить всё

Private Sub Test()
    Dim iArr As Variant, iRow&
    iArr = Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp)).Value

    Application.ScreenUpdating = False
    For iRow = UBound(iArr) To LBound(iArr) Step -1
        If iArr(iRow, 1) = "3311св" Then Rows(iRow).Resize(2).Insert
    Next
    Application.ScreenUpdating = True
End Sub

Код: Выделить всё

Private Sub Test2()
    Dim iSource As Range, iCell As Range, iCount&
    Set iSource = Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp))
    Set iCell = iSource(1)
    
    Application.ScreenUpdating = False
    For iCount = 1 To Application.CountIf(iSource, "3311св")
        Set iCell = iSource.Find("3311св", iCell, xlValues, xlWhole)
        iCell.Resize(2).EntireRow.Insert
    Next
    Application.ScreenUpdating = True
End Sub

[blackeangel]

Два примера поиска "3311св" в столбце [B:B] с последующей вставкой двух строк.

Спасибо.
это вставка пустых строк?
Просто у меня в 2003 экселе выдает 1004 ошибку
Если да,но надо не пустых,а тех что на листе 2. Или их аналог в коде

[pashulka]

1) Да, пустых
2) Ошибку 1004 можно получить, если, к примеру, рабочий лист + ячейки будут защищены
3) Если речь идёт о первых двух строк рабочего листа с именем "Лист2", то можете использовать что-то вроде нижеопубликованного кода, только учтите, что копируемые строки содержат формулы, а строки исходной таблицы - нет

Код: Выделить всё

Private Sub Test()
    Dim iArr As Variant, iRow&
    With Лист2
         iArr = .Range(.Cells(1, "B"), .Cells(Rows.Count, "B").End(xlUp)).Value
    End With
    
    Application.ScreenUpdating = False
    For iRow = UBound(iArr) To LBound(iArr) Step -1
        If iArr(iRow, 1) = "3311св" Then
           Лист3.Rows("1:2").Copy
           Лист2.Rows(iRow).Resize(2).Insert xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

[blackeangel]

1) Да, пустых
2) Ошибку 1004 можно получить, если, к примеру, рабочий лист + ячейки будут защищены
3) Если речь идёт о первых двух строк рабочего листа с именем "Лист2", то можете использовать что-то вроде нижеопубликованного кода, только учтите, что копируемые строки содержат формулы, а строки исходной таблицы - нет

Код: Выделить всё

Private Sub Test()
    Dim iArr As Variant, iRow&
    With Лист2
         iArr = .Range(.Cells(1, "B"), .Cells(Rows.Count, "B").End(xlUp)).Value
    End With
    
    Application.ScreenUpdating = False
    For iRow = UBound(iArr) To LBound(iArr) Step -1
        If iArr(iRow, 1) = "3311св" Then
           Лист3.Rows("1:2").Copy
           Лист2.Rows(iRow).Resize(2).Insert xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

вообще не мур мур.Вы сами то пробовали к файлу который я приложил применить?

Код: Выделить всё

Лист3.Rows("1:2").Copy

это вы что копируете 2 строки одного столбца? или наоборот? а надо н стобцов и 2 строки. Там же выделено как надо скопировать.Потом, что-то в тексте не заметил выделения копируемой области.

вот что то уже почти готовое

Код: Выделить всё

Sub Insert_Rows2()
    Dim lLastRow As Long, li As Long, i As Range ' переменные
    Application.ScreenUpdating = 0 'заморозим экран от изменений
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 'переменной присваивается последняя строка
    For li = lLastRow To 3 Step -1 'ПЕРЕБИРАЕМ С последней до первой строки с шагом -1
    With ActiveSheet.UsedRange.Rows(li).Resize(2)
    .Insert 'добавляем 2 строки до нужной нам
        With .Offset(-2)
            .Value = .Offset(2).Resize(1).Value
            .Columns(6) = 0: Intersect(.Cells, [H:H,J:L]) = Empty
            .Cells(1, 1) = .Cells(1, 1) - 10: .Cells(2, 1) = .Cells(1, 1) + 5
            .Columns(2) = Application.Substitute(.Columns(2), "св", Application.Transpose(Array("мз", "об")))
        End With
    End With
    ' если заменить Resize(2) на Resize(1) то будет вставляться только одна строка
    Next li
    Application.ScreenUpdating = 1 'разморозили экран и он обновился
End Sub

[pashulka]

Вы сами то пробовали к файлу который я приложил применить?

Да, и я получил результат полностью аналогичный таблице - Должно быть

[blackeangel]

Да, и я получил результат полностью аналогичный таблице - Должно быть

выложите пожалуйста файл

[pashulka]

См. аттач (таблица 'Должно быть' перенесена в отдельный лист, чтобы, образно говоря, не мешалась под ногами)

[blackeangel]

См. аттач (таблица 'Должно быть' перенесена в отдельный лист, чтобы, образно говоря, не мешалась под ногами)

тогда почему при копировании на другую книгу не работает? потому что листы разные например?
тогда надо что то "актив лист+1"

[pashulka]

тогда почему при копировании на другую книгу не работает? потому что листы разные например?

Значит в другой книге :
нет листов с кодовыми именами Лист2 и Лист3
и/или исходные данные располагаются в других столбцах/строках

тогда надо что то "актив лист+1"

Кто Вам мешает использовать индекс(номер) листа или ActiveSheet и ActiveSheet.Next