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

@blackeangel · Регистрация: 22.07.2015

Студворк — интернет-сервис помощи студентам

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

Кликните здесь для просмотра всего текста

Visual Basic

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

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

Кликните здесь для просмотра всего текста

Visual Basic

' это вставка двух строк при нахождении фразы,но в выделенной ¤чейке
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

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

@Vlad999 · 23.07.2015, 09:29

Visual Basic

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
    Rows(li).Resize(2).Insert 'добавляем 2 строки до нужной нам
' если заменить Resize(2) на Resize(1) то будет вставляться только одна строка
       Sheets("Лист2").Rows("1:2").Copy
       Range("A" & li).PasteSpecial
    Next li
    Application.CutCopyMode = False
    Application.ScreenUpdating = 1 'разморозили экран и он обновился
End Sub

в вашем примере ниже таблицы куча вставленных строк - почистите их.
становитесь в А27 и жмете Ctrl+Shift+End после удалить строки.
про поиск критерия не понял т.к. в файле Оленя не нашел.

@blackeangel · 23.07.2015, 20:21 **[ТС]**

да,оленя нет,но это не суть,вместо него может быть любой текст,например тут 3311св

@Vlad999 · 24.07.2015, 08:33

с проверкой так

Visual Basic

For li = lLastRow To 3 Step -1 'ПЕРЕБИРАЕМ С последней до первой строки с шагом -1
  If Cells(li,2)="3311св" Then 'если значение во втором столбце равно искомому то
    Rows(li).Resize(2).Insert 'добавляем 2 строки до нужной нам
' если заменить Resize(2) на Resize(1) то будет вставляться только одна строка
       Sheets("Лист2").Rows("1:2").Copy
       Range("A" & li).PasteSpecial
end if
    Next li

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 891
	23.07.2015, 20:21 [ТС]	3
	да,оленя нет,но это не суть,вместо него может быть любой текст,например тут 3311св 0

Опции темы