Страницы: 1
RSS
Вставка строк макросом
 
Есть макрос по вставке пустых строк,он предлагает выбор количества вставляемых строк, а как сделать чтобы он предлагал выбор через сколько строк вставлять?  
 
Sub InsertRows()  
Dim i As Long, nRow As Long, k As Long  
Dim x As Long  
   With Application  
       .ScreenUpdating = False  
       .Calculation = xlCalculationManual  
       nRow = Cells(Rows.Count, 1).End(xlUp).Row  
         
       k = InputBox("Введите количество строк для вставки между строками", , 1)  
             
           For i = nRow To 2 Step -1  
             Cells(i, 1).EntireRow.Insert  
                If k > 1 Then  
                   For x = k To 2 Step -1  
                      Cells(i, 1).EntireRow.Insert  
                   Next x  
                End If  
           Next i  
       .Calculation = xlCalculationAutomatic  
       .ScreenUpdating = True  
   End With  
   MsgBox "Строки добавлены!", vbInformation, "Вставка строк"  
End Sub
 
Step -1  
 
замените на Step -2
 
Похоже на первые мои попытки макросописания:))  
Возможно так:))) Но подгонять начало-конец данных под шаг :((( не сделано  
Игорь67  
---------------  
 
Sub InsertRows()  
Dim i As Long, nRow As Long    
Dim k As integer, x As integer  
 
With Application  
.ScreenUpdating = False  
.Calculation = xlCalculationManual  
nRow = Cells(Rows.Count, "A").End(xlUp).Row  
 
k = InputBox("Введите количество строк для вставки между строками", , 1)  
x = InputBox("Введите шаг вставки строк", , 1)  
 
For i = nRow To 2 Step -x  
Cells(i, 1).resize(k).EntireRow.Insert  
Next i  
.Calculation = xlCalculationAutomatic  
.ScreenUpdating = True  
End With  
MsgBox "Строки добавлены!", vbInformation, "Вставка строк"  
End Sub
 
Игорь67, спасибо. Тема закрыта.
 
Подскажите, пожалуйста, как нужно изменить этот макрос, чтобы пустые строки вставлялись только один раз. Мне нужно вставить пустые строки ниже активной ячейки и только один раз. Никак не могу разобраться  - что нужно удалить (. А есть где-нибудь доступная литература на русском, а то даже не знаешь, какие вопросы задавать. Вот вызвала справку в программе, спрашиваю что такое Application InputBox и она мне выдает - нет результатов (((
 
Lia, Вы лучше выложите пример, так будет легче помочь ;)  
 
Литература:  
http://www.planetaexcel.ru/forum.php?forum_id=147  
http://www.planetaexcel.ru/forum.php?thread_id=8763  
http://excelvba.ru/books  
и т.д.
<FONT COLOR="CadetBlue">
 
Application InputBox - такого нет.  
Есть Application.InputBox, Application и InputBox.  
Чтоб вставлять один раз - нужно убрать цикл.  
Вместо переменной i использовать ActiveCell.Row.  
А запрос Вам тоже каждый раз нужен? Тогда запрос оставьте.
 
Вот, преобразовал (лишнее закомментировал, одну строку добавил (продублировал, чуть изменив):  
 
Sub InsertRows()  
'Dim i As Long, nRow As Long  
Dim k As Integer, x As Integer  
 
With Application  
.ScreenUpdating = False  
.Calculation = xlCalculationManual  
'nRow = Cells(Rows.Count, "A").End(xlUp).Row  
 
k = InputBox("Введите количество строк для вставки между строками", , 1)  
'x = InputBox("Введите шаг вставки строк", , 1)  
 
'For i = nRow To 2 Step -x  
'Cells(i, 1).Resize(k).EntireRow.Insert  
'Next i  
 
Cells(ActiveCell.Row, 1).Resize(k).EntireRow.Insert  
 
.Calculation = xlCalculationAutomatic  
.ScreenUpdating = True  
End With  
MsgBox "Строки добавлены!", vbInformation, "Вставка строк"  
End Sub
 
Добавил рюшечки :)  
---------------------  
Sub InsertRows()  
 
   Dim k As Long  
 
   With Application  
       .ScreenUpdating = False  
       .Calculation = xlCalculationManual  
   End With  
 
   k = Application.InputBox(Prompt:="Введите количество строк:", _  
       Title:="Добавить строки", Default:=1, Type:=1)  
     
   If k = 0 Then Exit Sub  
     
   Cells(ActiveCell.Row, 1).Resize(k).EntireRow.Insert  
 
   With Application  
       .Calculation = xlCalculationAutomatic  
       .ScreenUpdating = True  
   End With  
 
End Sub  
---------------------
<FONT COLOR="CadetBlue">
 
Так правильнее  
 
Cells(ActiveCell.Row + 1, 1).Resize(k).EntireRow.Insert
 
Точно, ведь просили НИЖЕ...
 
Какие вы все молодцы! Спасибо большое, все работает, и за последнее исправление спасибо - сама пробовала - почему-то не получалось. Сейчас работу сделаю, а по свободе почитаю что-нибудь - мне ведь элементарного не хватает - что значат переменные, как правильно записывать - а справка-то на английском. Это когда и на русском не очень понятно...
 
Не знаете почему опен офис не дружит с макросами  
микрософт офис , очень хочется в опен офисе научиться вставлять строку в месте курсора .  
а то когда макрос записываеш он строку вставляет в том месте где при записи макроса ее вставил.  
т е хочется вставить строку и растянуть на нее формулы из верхней строки  
но там где стоит курсор а не в конкретном номере строки    
эх даже объяснить сложно (  
спасибо !
 
Антон, Вы ошиблись Форумом - здесь разговоры про Excel.
 
Антон, к сожалению ОО не поддерживает ВБА. Макрокоманды пишут и в ОО, но это уже совсем другой язык программирования и мы Вам не сможем помочь:(
 
{quote}{login=Юрий М}{date=02.09.2011 03:36}{thema=}{post}Антон, Вы ошиблись Форумом - здесь разговоры про Excel.{/post}{/quote}  
 
в ОО тоже эксель есть , спасибо что откликнулись    
брошу все силы чтобы админы установили микрософт
 
В ОО нет Экселя. Есть Calc. А это две большие разницы.
Я сам - дурнее всякого примера! ...
 
Уважаемые знатоки-форумчане!  
 
У меня похожая ситуация и я не знаю как с ней справиться. Помогите пожалуйста!  
Дело есть так: Есть две колонки: в одном даты, во второй действия (которые нужно сделать в указанные даты). Это своеобразный список заданий (планировщик) на будущее.  
 
Задача: при каждом открытии файла автоматически должна создаваться строка с текстом примерно следующего содержания: "сегодня такое то число, такого-то месяца и т.д.), т.е. имея список дел при открытии ты сразу видишь вставленную строку с сегодняшней датой, таким образом ты делишь весь списко на вчера (т.е. то, что уже прошло) и завтра (т.е. то, что предстоит сделать).  
Вот как это сделать? Причем один раз открыв такой файл - получаем строку с датой СЕГОДНЯ, при открытии через несколько дней - получаем эту же строку но в другом месте, а в прошлом месте - нужно удалить ту созданную строку.  
 
Примерно должно выглядеть так:  
01.01.2012 - позвонить  
05.01.2012 - прочитать  
10.01.2012 - написать  
 
после открытия такого файла 3-го числа получаем новую строку между 01 и 05:  
01.01.2012 - позвонить  
---СЕГОДНЯ 03.01.2012---  
05.01.2012 - прочитать  
10.01.2012 - написать  
 
после открытия 7 января получаем следующее:  
01.01.2012 - позвонить  
05.01.2012 - прочитать  
---СЕГОДНЯ 07.01.2012---  
10.01.2012 - написать  
 
Заранее спасибо за советы, рекомендации, помощь!
 
Да... два года не прошли даром :)  
 
Код в модуле эта книга.
 
Уважаемый sva  
 
Спасибо Вам большое. Работает! Ура!  
Я алгоритм понимаю решения, а вот сам язык не знаю, поэтому тяжело команды методом тыка и перебора подбирать.    
Еще раз Вам спасибо.
 
Уважаемые форумчане, спасибо за напутствие, особенно Роману {login=sva} за код.  
На основе этого кода я разобрался более подробней и даже внес которые свои улучшения, а именно:  
1. Т.к. таблица имеет несколько столбов, то я для удобства объеденил ячейки вставляемой строки в одну.  
2. Эту самую одну ячейку с датой СЕГОДНЯ несколько отформатировал:  
- изменил шрифт текста,  
- расположение текста посередине ячейки,  
- цвет фона ячейки белый (в отличии от других ячеек, которые подкрашенны в разные цвета,  
- задал формат рамки ячейки.  
 
Вот сам код:  
Private Sub Workbook_Open()  
Dim i As Long  
Application.ScreenUpdating = 0  
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1  
   If InStr(Cells(i, 1), "Сегодня") > 0 Then  
       Rows(i).Delete  
       Exit For  
   End If  
Next  
 
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row  
   If Cells(i, 1) > Date Then  
   Rows(i).Resize(1).EntireRow.Insert  
   Cells(i, 1).Value = "Сегодня " & Date  
   Range(Cells(i, 1), Cells(i, 4)).MergeCells = True  
   Range(Cells(i, 1), Cells(i, 4)).HorizontalAlignment = xlCenter  
   Range(Cells(i, 1), Cells(i, 4)).Borders.ColorIndex = 3  
   Range(Cells(i, 1), Cells(i, 4)).Borders.Weight = 4  
   Range(Cells(i, 1), Cells(i, 4)).Interior.ColorIndex = 0  
   Range(Cells(i, 1), Cells(i, 4)).Font.Bold = True  
   Range(Cells(i, 1), Cells(i, 4)).Font.Size = 16  
 
   Exit Sub  
   End If  
Next  
Application.ScreenUpdating = 1  
End Sub  
 
 
Но кроме этого у меня есть вопросы, которые я сам не могу разобрать, помогите пожалуйста решить их, а именно:  
Т.к. таблица со временем будет вырастать и вырастать, то было бы очень хорошо, если бы при открытии автоматически перемещаться к строке с датой СЕГОДНЯ, а не прокручивать вручную. Вот как сделать это автоматическое перемещение при открытии?
 
Private Sub Workbook_Open()  
Dim i As Long  
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1  
If InStr(Cells(i, 1), "Сегодня") > 0 Then  
Rows(i).Delete  
Exit For  
End If  
Next  
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row  
If Cells(i, 1) > Date Then  
Rows(i).Resize(1).EntireRow.Insert  
Cells(i, 1).Value = "Сегодня " & Date  
Cells(i, 1).Activate 'активируем нужную ячейку  
With Range(Cells(i, 1), Cells(i, 4))  
.MergeCells = True  
.HorizontalAlignment = xlCenter  
.Borders.ColorIndex = 3  
.Borders.Weight = 4  
.Interior.ColorIndex = 0  
.Font.Bold = True  
.Font.Size = 16  
End With  
Exit Sub  
End If  
Next  
 
End Sub
 
Ура! Работает! :)
 
Уважаемые форумчане!  
 
Позвольте просить вашей помощи: задача стоит такая: в определенном диапозоне проверить цвет ячейки и поменять его на пол тона бледнее (т.е. если был желтый (№6) - то сделать бледно желтым (№36), если был серый (№15) - то делаем бледно серый (№24).  
Причем у меня в коде уже есть раздел, который меняет в данном определенном диапазоне шрифт текста (приведу этот кусок кода):  
   With Range(Cells(3, 1), Cells(i, 7))  
       .Font.Bold = False  
       .Font.Size = 10  
       .Font.Italic = False    
   End With  
 
Вот теперь к этому куску стоит задача добавить выборку по каждой ячейке и изменении цвета на другой, я это вижу так (но так не работает):  
   With Range(Cells(3, 1), Cells(i, 7))  
       .Font.Bold = False  
       .Font.Size = 10  
       .Font.Italic = False    
         
       For each Cells in Range(Cells(3, 1), Cells(i, 7))  
          If Cell.Interior.ColorIndex = 6 Then  
          Cell.Interior.ColorIndex = 36  
          End If  
             
          If Cell.Interior.ColorIndex = 15 Then  
          Cell.Interior.ColorIndex = 24  
          End If  
 
   End With  
 
Как правильно записать код на изменение цвета? Можно ли в подгруппе With Range это написать, или нужно отдельно?  
Заранее спасибо!  
 
П.С. Простите код очень большой из-за того, что я его наполняю комментариями, для того, чтобы не забыть что для чего делал (это я для себя так пишу).
 
With Range(Cells(3, 1), Cells(i, 7))  
       .Font.Bold = False '-делаем шрифт не полужирным (отменяем полужирность)  
       .Font.Size = 10 '-размер шрифта уменьшаем с 11 до 10  
       .Font.Italic = False '-если бы был наклонный текст - то мы его бы отменили  
       For Each Cell In .Cells  
       If Cell.Interior.ColorIndex = 6 Then Cell.Interior.ColorIndex = 36  
       If Cell.Interior.ColorIndex = 15 Then Cell.Interior.ColorIndex = 24  
       Next          
End With  
 
А вообще ваш вопрос не имеет отношения к данной теме, и по хорошему нужно было бы создать новую.
 
Спасибо за совет! и сорри за флуд.
Страницы: 1
Наверх