Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » pro_sys
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
Добавление строк при нажатие на кнопку, С копированием формул по условию
 
#
15.02.2018 19:26:53
Господа прошу помочь с макросом для автоматического добавления 10 строк при нажатие на кнопку с копированием формул по условию.
На данный момент почти отладил его работу, но встрял на следующем:
1. При первом нажатие добавляется 10-ть строк, а при повторном - всего одна.
2. Новые строки появляются после максимального значения в столбце А, но мне нужно, что бы они добавлялись после последней ячейке таблицы и не важно заполнена она или нет... и вот здесь я совсем встрял...
Код
Sub ADD()
Application.ScreenUpdating = False
    
    Dim wsheet As Worksheet
    Dim iLastrow As Integer
    Dim m As Integer, i As Integer, strNum1 As Integer

                    With ThisWorkbook.Worksheets("Ввод")
                                iLastrow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                                m = Application.WorksheetFunction.Max(Range("a21:a" & iLastrow))
                                   For i = iLastrow To 1 Step -10
                                         If Cells(i, 1) = m Then
                                            If strNum1 = 0 Then
                                                strNum1 = i
                                                Rows(strNum1 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                                                Range(Cells(strNum1, 1), Cells(strNum1, 25)).AutoFill Destination:=Range(Cells(strNum1, 1), Cells(strNum1 + 10, 25)), Type:=xlFillDefault
                                                Range(Cells(strNum1 + 1, 1), Cells(strNum1 + 10, 6)).ClearContents
                                                Range(Cells(strNum1 + 1, 11), Cells(strNum1 + 10, 11)).ClearContents
                                                Range(Cells(strNum1 + 1, 15), Cells(strNum1 + 10, 18)).ClearContents
                                    
                                    Exit For
      
                                             End If
                                            End If
                                 Next i
                    End With
                            

    Application.ScreenUpdating = True
End Sub
 
Перейти    
Запуск макроса на нескольких листах при нажатие на кнопку, условия копирования данных на листах разные
 
#
02.02.2018 19:43:34
Разобрался сам, но осталась одна проблема....
После первого нажатия на кнопку добавляется все как надо, т.е. 10строк, а после повторного нажатия +1строка... как поправить это?!
Код
Sub ADD()
Application.ScreenUpdating = False

    
        Dim wsheet As Worksheet
        Dim iLastrow As Integer
        Dim m As Integer, i As Integer, strNum1 As Integer, strNum2 As Integer

            Worksheets("Ввод").Select
            For Each wsheet In ActiveWorkbook.Sheets
                     wsheet.Unprotect "1234"
                Next wsheet
    
                        With Worksheets("Ввод")
                                    iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                                    m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))
                                
                                        For i = 1 To iLastrow
                                            If Cells(i, 1) = m Then
                                                If strNum1 = 0 Then
                                                    strNum1 = i
                                                    Rows(strNum1 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                                                    Range(Cells(strNum1, 1), Cells(strNum1, 25)).AutoFill Destination:=Range(Cells(strNum1, 1), Cells(strNum1 + 10, 25)), Type:=xlFillDefault
                                                    Range(Cells(strNum1 + 1, 1), Cells(strNum1 + 10, 6)).ClearContents
                                                    Range(Cells(strNum1 + 1, 11), Cells(strNum1 + 10, 11)).ClearContents
                                                    Range(Cells(strNum1 + 1, 15), Cells(strNum1 + 10, 18)).ClearContents
                                        
                                                    Exit For
                                                End If
                                            End If
                                     Next i
                         End With
            
            Worksheets("Проверка").Select
                         With Worksheets("Проверка")
                                      iLastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                                      m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))
                                                
                                          For i = 1 To iLastrow
                                              If Cells(i, 1) = m Then
                                                  If strNum2 = 0 Then
                                                      strNum2 = i
                                                      Rows(strNum2 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                                                      Range(Cells(strNum2, 1), Cells(strNum2, 25)).AutoFill Destination:=Range(Cells(strNum2, 1), Cells(strNum2 + 10, 25)), Type:=xlFillDefault
                    
                                                        
                                                                   Exit For
                                                               End If
                                                           End If
                                                    Next i
                                       End With
    
            For Each wsheet In ActiveWorkbook.Sheets
                     wsheet.Protect "1234"
                Next wsheet
Application.ScreenUpdating = True
End Sub
Изменено: pro_sys - 02.02.2018 19:44:08
 
Перейти    
Запуск макроса на нескольких листах при нажатие на кнопку, условия копирования данных на листах разные
 
#
02.02.2018 16:26:56
Правильно я понимаю, что тогда код должен быть такой:

Код
Sub ADD()
Application.ScreenUpdating = False

    Dim iLastrow As Integer
    Dim m As Integer, i As Integer, strNum1 As Integer, strNum2 As Integer

                    With ThisWorkbook.Worksheets("Ввод")
                                iLastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                                m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))
                            
                                    For i = 1 To iLastrow
                                        If Cells(i, 1) = m Then
                                            If strNum1 = 0 Then
                                                strNum1 = i
                                                Rows(strNum1 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                                                Range(Cells(strNum1, 1), Cells(strNum1, 25)).AutoFill Destination:=Range(Cells(strNum1, 1), Cells(strNum1 + 10, 25)), Type:=xlFillDefault
                                                Range(Cells(strNum1 + 1, 1), Cells(strNum1 + 10, 6)).ClearContents
                                                Range(Cells(strNum1 + 1, 11), Cells(strNum1 + 10, 11)).ClearContents
                                                Range(Cells(strNum1 + 1, 15), Cells(strNum1 + 10, 18)).ClearContents
                                    
                                                Exit For
                                            End If
                                        End If
                                 Next i
                    End With
                            
        
                    With ThisWorkbook.Worksheets("Проверка")
                                iLastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                                m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))
                            
                                    For i = 1 To iLastrow
                                        If Cells(i, 1) = m Then
                                            If strNum2 = 0 Then
                                                strNum2 = i
                                                Rows(strNum2 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                                                Range(Cells(strNum2, 1), Cells(strNum2, 25)).AutoFill Destination:=Range(Cells(strNum2, 1), Cells(strNum2 + 10, 25)), Type:=xlFillDefault

                                    
                                                Exit For
                                            End If
                                        End If
                                 Next i
                    End With
          
    Application.ScreenUpdating = True
End Sub

Но в этом случае на листе "Ввод" происходит копирование строк по условиям, которые должны быть на листе "Проверка" ...., т.е. первая половина кода вообще не активна остается, а вторая работает не на том листе... хрень какая-то....Аааааа!!!!!! (((

Изменено: pro_sys - 02.02.2018 23:08:17
 
Перейти    
Запуск макроса на нескольких листах при нажатие на кнопку, условия копирования данных на листах разные
 
#
02.02.2018 15:05:00
Цитата
Anchoret написал:
т.е. нужно указать название листа при обращении к диапазону. А виды деятельности на каждом из листов разграничить набором условий.
Видимо я дико туплю, потому что это не помогает... Я уже пытался разделить выполнение функцией на листах при помощи With, но это не помогло...
Мне кажется проблема именно в этой строчке:
Код
            m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))
Как задать поиск максимального значения не на рабочем листе, а на листе например "Ввод"
Извините если вопрос тупой, но я уже задолбался решать эту проблему)))
 
Перейти    
Запуск макроса на нескольких листах при нажатие на кнопку, условия копирования данных на листах разные
 
#
01.02.2018 18:34:46
Добрый день форумчане)

Не силен в макросах и наверное поэтому ломаю уже второй день голову...
Собственно задача следующая: при нажатие на кнопку должен запускать макрос, который добавляет на:
1. на Листе "Ввод" после последней ячейки таблицы 10-ть строк с условием, что некотрые из этих ячеек, которые располагаются в определенных столбцах будут очищены от данных, а остальные нет.
2. на Листе "Проверка" должны так же добавляться после последней ячейки аналогичной таблицы 10-ть строк, но уже без условий по очистке данных.
Доп. уточнение: названия и количество столбцов на листах полностью совпадает, как и начало таблиц расположенных на них.

На данным момент мне удалось реализовать ввод 10-ти строк на рабочем листе "Ввод" после максимально найденного значения в диапазоне и задать условия по очистке данных в определенных столбцах. Собственно остались такие вопросы:

1. Как реализовать выполнение макроса "добавления строк в таблицу" на НЕСКОЛЬКИХ ЛИСТАХ при нажатие одной кнопки, так что бы на листе "Ввод" были условия по копированию данных из строк выше, а на листе "Проверка" их не было
2. Как сделать добавление строк после ПОСЛЕДНЕЙ ячейки таблицы, а не ячейки содержащей максимальное значение...

Код
Sub ADD()
Application.ScreenUpdating = False
    Dim iLastrow As Integer
    Dim m As Integer, i As Integer, strNum1 As Integer, strNum2 As Integer

    iLastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    m = Application.WorksheetFunction.Max(Range("a1:a" & iLastrow))


    For i = 1 To iLastrow
        If Cells(i, 1) = m Then
            If strNum1 = 0 Then
                strNum1 = i
                Rows(strNum1 + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Range(Cells(strNum1, 1), Cells(strNum1, 25)).AutoFill Destination:=Range(Cells(strNum1, 1), Cells(strNum1 + 10, 25)), Type:=xlFillDefault
                Range(Cells(strNum1 + 1, 1), Cells(strNum1 + 10, 6)).ClearContents
                Range(Cells(strNum1 + 1, 11), Cells(strNum1 + 10, 11)).ClearContents
                Range(Cells(strNum1 + 1, 15), Cells(strNum1 + 10, 18)).ClearContents

        
                Exit For
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
Изменено: pro_sys - 02.02.2018 16:28:25
 
Перейти    
Страницы: 1
Наверх