В общем помогите написать код для вставки 2 строк от первой до последней на листе с учетом имеющейся в них фразах.Например,если в строке по всем столбцам есть слово Олень,то мы вставляем 2 строки над этой строкой,если нет,то пропускаем или (что лучше) ищем по другому условию. Заполняются они в самом коде либо как вариант копируются с другого листа. Количество строк - столько сколько поддерживает эксель(точнее более 180000) Копируется одно и тоже, но разное количество строк. Вот начал писать через копи паст с другого листа,но копирует только 1 значение и один раз,что опять не по циклу. Код:
[vba]
Код
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
[/vba]
но тут не работает поиск,он ищет только первое значение и вставляет пустые строки. Код:
[vba]
Код
' это вставка двух строк при нахождении фразы,но в выделенной ¤чейке 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
[/vba]
Файл прилагаю. [moder]Для оформления кода используйте кнопку #, а не спойлер. Исправила[/moder]
В общем помогите написать код для вставки 2 строк от первой до последней на листе с учетом имеющейся в них фразах.Например,если в строке по всем столбцам есть слово Олень,то мы вставляем 2 строки над этой строкой,если нет,то пропускаем или (что лучше) ищем по другому условию. Заполняются они в самом коде либо как вариант копируются с другого листа. Количество строк - столько сколько поддерживает эксель(точнее более 180000) Копируется одно и тоже, но разное количество строк. Вот начал писать через копи паст с другого листа,но копирует только 1 значение и один раз,что опять не по циклу. Код:
[vba]
Код
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
[/vba]
но тут не работает поиск,он ищет только первое значение и вставляет пустые строки. Код:
[vba]
Код
' это вставка двух строк при нахождении фразы,но в выделенной ¤чейке 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
[/vba]
Файл прилагаю. [moder]Для оформления кода используйте кнопку #, а не спойлер. Исправила[/moder]blackeangel
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
[/vba]
blackeangel, так нужно? [vba]
Код
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