Смещение кнопок вниз после копирования строк макросом - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Смещение кнопок вниз после копирования строк макросом - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Смещение кнопок вниз после копирования строк макросом (Макросы/Sub)

Смещение кнопок вниз после копирования строк макросом

Дата: Среда, 13.04.2022, 18:15 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

День добрый.
снизу таблицы кнопки, после добавления строки (кнопка+) кнопки смещаются вниз, как сделать то же самое при дублировании строк (кнопка дублировать)

К сообщению приложен файл: 2937405.xlsb (18.0 Kb)

Ответить

Дата: Четверг, 14.04.2022, 08:40 | Сообщение № 2

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

micholap_denis, приветствую!
Выделяете строку для дублирования и она добавляется в конец таблицы
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow
    Set iRow = Selection
    With Sheets("Лист1").ListObjects("Таблица1")
        Set tRow = .ListRows.Add
        Rows(iRow.Row).Copy tRow.Range
    End With
End Sub

[/vba]

К сообщению приложен файл: 3560811.xlsb (19.3 Kb)

Сообщение отредактировал jun - Четверг, 14.04.2022, 08:40

Ответить

Дата: Четверг, 14.04.2022, 10:39 | Сообщение № 3

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, одну дублирует,а если группу строк? несколько строк и если фильтр применен....

Ответить

Дата: Четверг, 14.04.2022, 11:52 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

micholap_denis, исправил, теперь учитывает и фильтр и несколько строк:
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow, i As Range
    Set iRow = Selection
    With Sheets("Лист1").ListObjects("Таблица1")
        For Each i In iRow.Rows
            If i.EntireRow.Hidden = False Then
                Set tRow = .ListRows.Add
                i.Copy tRow.Range
            End If
        Next i
    End With
End Sub

[/vba]
Проверяйте

К сообщению приложен файл: 7315460.xlsb (18.5 Kb)

Ответить

Дата: Пятница, 15.04.2022, 13:40 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 98

Репутация: 25 ±

Замечаний: 0% ±

Excel 2010

удалено

Сообщение отредактировал mgt - Пятница, 15.04.2022, 13:40

Ответить

Дата: Четверг, 28.04.2022, 17:00 | Сообщение № 6

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, Спасибо работает,
извините если наглею, но макрос дублирования изменился (шустрее в файле оригинале работает) как бы его допилить что бы так же кнопки смещались..
и так же в файле присутствует макрос вставки группы строк с листа шаблон, как бы что бы тоже при вставке кнопки смещались...
пример прикладываю

К сообщению приложен файл: 11111.xlsb (35.6 Kb)

Ответить

Дата: Четверг, 28.04.2022, 17:47 | Сообщение № 7

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

micholap_denis, макрос для вставки группы строк подправил:
[vba]

Код

Private Sub CommandButton1_Click() ' копирование строк по выбранному признаку
    Dim res(), pz&
    Application.ScreenUpdating = False
    признак = ComboBox1.Value
    Set Tbl1 = Me.ListObjects(1)
    Set Tbl2 = ThisWorkbook.Worksheets("Шаблоны").ListObjects(1)
    pz = 0
    dx = Tbl2.DataBodyRange
    Col = Tbl2.ListColumns("признак").Index
    ReDim res(1 To UBound(dx), 1 To UBound(dx, 2))
    For i = 1 To UBound(dx)
        If dx(i, Col) = признак Then
            pz = pz + 1
            For n = 1 To UBound(dx, 2)
                res(pz, n) = dx(i, n)
            Next
        End If
    Next
    If pz > 0 Then
        Dim LastRow As Long

        With Sheets("Таблица").ListObjects("Таблица1")
            LastRow = .ListRows.Count
            For i = 1 To UBound(res, 1)
                .ListRows.Add
            Next i
        End With
        Debug.Print (UBound(res, 1))
        Tbl1.ListRows(LastRow + 1).Range.Cells(1, 1).Resize(pz, UBound(res, 2)) = res
    End If
    Application.ScreenUpdating = True
End Sub

[/vba]

Цитата micholap_denis, 28.04.2022 в 17:00, в сообщении № 6 (

)

но макрос дублирования изменился (шустрее в файле оригинале работает) как бы его допилить что бы так же кнопки смещались..

Имеется в виду макрос вот этот макрос?
[vba]

Код

Sub Дублированиестрок()
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    targetRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
    'ActiveSheet.Cells(targetRow, 1) = "-"
    Set sh = Worksheets.Add
    Лист1.Activate
    Selection.SpecialCells(12).Copy sh.Range("A1")
    sh.UsedRange.Copy ActiveSheet.Rows(targetRow)
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[/vba]

micholap_denis, макрос для вставки группы строк подправил:
[vba]

Код

Private Sub CommandButton1_Click() ' копирование строк по выбранному признаку
    Dim res(), pz&
    Application.ScreenUpdating = False
    признак = ComboBox1.Value
    Set Tbl1 = Me.ListObjects(1)
    Set Tbl2 = ThisWorkbook.Worksheets("Шаблоны").ListObjects(1)
    pz = 0
    dx = Tbl2.DataBodyRange
    Col = Tbl2.ListColumns("признак").Index
    ReDim res(1 To UBound(dx), 1 To UBound(dx, 2))
    For i = 1 To UBound(dx)
        If dx(i, Col) = признак Then
            pz = pz + 1
            For n = 1 To UBound(dx, 2)
                res(pz, n) = dx(i, n)
            Next
        End If
    Next
    If pz > 0 Then
        Dim LastRow As Long

        With Sheets("Таблица").ListObjects("Таблица1")
            LastRow = .ListRows.Count
            For i = 1 To UBound(res, 1)
                .ListRows.Add
            Next i
        End With
        Debug.Print (UBound(res, 1))
        Tbl1.ListRows(LastRow + 1).Range.Cells(1, 1).Resize(pz, UBound(res, 2)) = res
    End If
    Application.ScreenUpdating = True
End Sub

[/vba]

Цитата micholap_denis, 28.04.2022 в 17:00, в сообщении № 6 (

)

но макрос дублирования изменился (шустрее в файле оригинале работает) как бы его допилить что бы так же кнопки смещались..

Имеется в виду макрос вот этот макрос?
[vba]

Код

Sub Дублированиестрок()
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    targetRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
    'ActiveSheet.Cells(targetRow, 1) = "-"
    Set sh = Worksheets.Add
    Лист1.Activate
    Selection.SpecialCells(12).Copy sh.Range("A1")
    sh.UsedRange.Copy ActiveSheet.Rows(targetRow)
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[/vba]jun

Ответить

Сообщениеmicholap_denis, макрос для вставки группы строк подправил:
[vba]

Код

Private Sub CommandButton1_Click() ' копирование строк по выбранному признаку
    Dim res(), pz&
    Application.ScreenUpdating = False
    признак = ComboBox1.Value
    Set Tbl1 = Me.ListObjects(1)
    Set Tbl2 = ThisWorkbook.Worksheets("Шаблоны").ListObjects(1)
    pz = 0
    dx = Tbl2.DataBodyRange
    Col = Tbl2.ListColumns("признак").Index
    ReDim res(1 To UBound(dx), 1 To UBound(dx, 2))
    For i = 1 To UBound(dx)
        If dx(i, Col) = признак Then
            pz = pz + 1
            For n = 1 To UBound(dx, 2)
                res(pz, n) = dx(i, n)
            Next
        End If
    Next
    If pz > 0 Then
        Dim LastRow As Long

        With Sheets("Таблица").ListObjects("Таблица1")
            LastRow = .ListRows.Count
            For i = 1 To UBound(res, 1)
                .ListRows.Add
            Next i
        End With
        Debug.Print (UBound(res, 1))
        Tbl1.ListRows(LastRow + 1).Range.Cells(1, 1).Resize(pz, UBound(res, 2)) = res
    End If
    Application.ScreenUpdating = True
End Sub

[/vba]

Цитата micholap_denis, 28.04.2022 в 17:00, в сообщении № 6 (

)

но макрос дублирования изменился (шустрее в файле оригинале работает) как бы его допилить что бы так же кнопки смещались..

Имеется в виду макрос вот этот макрос?
[vba]

Код

Sub Дублированиестрок()
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    targetRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
    'ActiveSheet.Cells(targetRow, 1) = "-"
    Set sh = Worksheets.Add
    Лист1.Activate
    Selection.SpecialCells(12).Copy sh.Range("A1")
    sh.UsedRange.Copy ActiveSheet.Rows(targetRow)
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[/vba]

Автор - jun
Дата добавления - 28.04.2022 в 17:47

Дата: Четверг, 28.04.2022, 20:46 | Сообщение № 8

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

Да этот

Ответить

Дата: Четверг, 28.04.2022, 22:02 | Сообщение № 9

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, спасибо
макрос вставки строк с листа шаблоны работает и кнопки смещаются , но добавляет строки не только те что отмечены в признаке и выбираются в форме, но и все остальные строки что на лист е шаблоны в таблице....лишние пустыми добавляет...как подправить?

Ответить

Дата: Пятница, 29.04.2022, 08:05 | Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

Цитата micholap_denis, 28.04.2022 в 22:02, в сообщении № 9 (

)

как подправить?

подправил
[vba]

Код

Private Sub CommandButton1_Click() ' копирование строк по выбранному признаку
    Dim res(), pz&, j
    Application.ScreenUpdating = False
    признак = ComboBox1.Value
    Set Tbl1 = Me.ListObjects(1)
    Set Tbl2 = ThisWorkbook.Worksheets("Шаблоны").ListObjects(1)
    pz = 1
    dx = Tbl2.DataBodyRange
    col = Tbl2.ListColumns("признак").Index
    For i = 1 To UBound(dx, 1)
        If dx(i, col) = признак Then
            For j = 1 To UBound(dx, 2)
                ReDim Preserve res(1 To pz)
                res(pz) = dx(i, j)
                pz = pz + 1
            Next j
        With Sheets("Таблица").ListObjects("Таблица1")
            LastRow = .ListRows.Count
            .ListRows.Add
            .ListRows(LastRow + 1).Range.Cells(1, 1).Resize(1, UBound(res)) = res
        End With
            Erase res
            pz = 1
        End If
    Next
Application.ScreenUpdating = True
End Sub

[/vba]

Цитата micholap_denis, 28.04.2022 в 20:46, в сообщении № 8 (

)

Да этот

можете объяснить, что он делает?

Сообщение отредактировал jun - Пятница, 29.04.2022, 08:15

Ответить

Дата: Пятница, 29.04.2022, 08:51 | Сообщение № 11

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, копирует и вставляет выделеные строки вниз таблицы. и при фитьтре
таже функция что и в вашем макросе...
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow, i As Range
    Set iRow = Selection
    With Sheets("Лист1").ListObjects("Таблица1")
        For Each i In iRow.Rows
            If i.EntireRow.Hidden = False Then
                Set tRow = .ListRows.Add
                i.Copy tRow.Range
            End If
        Next i
    End With
End Sub

[/vba]
только в оригинальном файле десятки тысяч строк и сотня столбцов, и вариант макроса Дублирование строк работает быстрее

Ответить

Дата: Пятница, 29.04.2022, 09:04 | Сообщение № 12

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, Тот что подправили работает...спасибо

Ответить

Дата: Пятница, 29.04.2022, 09:51 | Сообщение № 13

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

Цитата micholap_denis, 29.04.2022 в 08:51, в сообщении № 11 (

)

копирует и вставляет выделеные строки вниз таблицы. и при фитьтре

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

Можно изменить макрос по вставке строк (добавить SpecialCells):
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow, i As Range
    Set iRow = Selection
    With Sheets("Таблица").ListObjects("Таблица1")
        For Each i In iRow.SpecialCells(xlCellTypeVisible).Rows
'            If i.EntireRow.Hidden = False Then
                Set tRow = .ListRows.Add
                i.Copy tRow.Range
'            End If
        Next i
    End With
End Sub

[/vba]
Выделяете строки и в Таблице 1 и они вставляются ниже

Разобрался, код:
[vba]

Код

Sub Дублированиестрок()
    Dim i, lstRow As Long, rCount As Long
    Dim sh As Worksheet
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    Sheets(1).Activate
    Application.Selection.Copy sh.Cells(1, 1)
    rCount = sh.UsedRange.Rows.Count
    With Sheets("Таблица").ListObjects("Таблица1")
        lstRow = .DataBodyRange.Rows.Count
        For i = 1 To rCount
            .ListRows.Add
        Next i
        sh.UsedRange.Copy
        .ListRows(lstRow + 1).Range.Cells(1, 1).PasteSpecial xlValues
    End With
    sh.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[/vba]

Цитата micholap_denis, 29.04.2022 в 08:51, в сообщении № 11 (

)

копирует и вставляет выделеные строки вниз таблицы. и при фитьтре

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

Можно изменить макрос по вставке строк (добавить SpecialCells):
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow, i As Range
    Set iRow = Selection
    With Sheets("Таблица").ListObjects("Таблица1")
        For Each i In iRow.SpecialCells(xlCellTypeVisible).Rows
'            If i.EntireRow.Hidden = False Then
                Set tRow = .ListRows.Add
                i.Copy tRow.Range
'            End If
        Next i
    End With
End Sub

[/vba]
Выделяете строки и в Таблице 1 и они вставляются ниже

Разобрался, код:
[vba]

Код

Sub Дублированиестрок()
    Dim i, lstRow As Long, rCount As Long
    Dim sh As Worksheet
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    Sheets(1).Activate
    Application.Selection.Copy sh.Cells(1, 1)
    rCount = sh.UsedRange.Rows.Count
    With Sheets("Таблица").ListObjects("Таблица1")
        lstRow = .DataBodyRange.Rows.Count
        For i = 1 To rCount
            .ListRows.Add
        Next i
        sh.UsedRange.Copy
        .ListRows(lstRow + 1).Range.Cells(1, 1).PasteSpecial xlValues
    End With
    sh.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[/vba]jun

Сообщение отредактировал jun - Пятница, 29.04.2022, 11:17

Ответить

Сообщение

Цитата micholap_denis, 29.04.2022 в 08:51, в сообщении № 11 (

)

копирует и вставляет выделеные строки вниз таблицы. и при фитьтре

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

Можно изменить макрос по вставке строк (добавить SpecialCells):
[vba]

Код

Sub Дублировать()
    Dim iRow As Range, tRow, i As Range
    Set iRow = Selection
    With Sheets("Таблица").ListObjects("Таблица1")
        For Each i In iRow.SpecialCells(xlCellTypeVisible).Rows
'            If i.EntireRow.Hidden = False Then
                Set tRow = .ListRows.Add
                i.Copy tRow.Range
'            End If
        Next i
    End With
End Sub

[/vba]
Выделяете строки и в Таблице 1 и они вставляются ниже

Разобрался, код:
[vba]

Код

Sub Дублированиестрок()
    Dim i, lstRow As Long, rCount As Long
    Dim sh As Worksheet
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    Sheets(1).Activate
    Application.Selection.Copy sh.Cells(1, 1)
    rCount = sh.UsedRange.Rows.Count
    With Sheets("Таблица").ListObjects("Таблица1")
        lstRow = .DataBodyRange.Rows.Count
        For i = 1 To rCount
            .ListRows.Add
        Next i
        sh.UsedRange.Copy
        .ListRows(lstRow + 1).Range.Cells(1, 1).PasteSpecial xlValues
    End With
    sh.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[/vba]

Автор - jun
Дата добавления - 29.04.2022 в 09:51

Дата: Пятница, 29.04.2022, 12:19 | Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

micholap_denis, в дополнении к сообщению 7, еще можно реализовать так:
[vba]

Код

Private Sub CommandButton1_Click() ' копирование строк по выбранному признаку
    Dim res(), pz&, j
    Application.ScreenUpdating = False
    признак = ComboBox1.Value
    Set Tbl1 = Me.ListObjects(1)
    Set Tbl2 = ThisWorkbook.Worksheets("Шаблоны").ListObjects(1)
    pz = 1
    dx = Tbl2.DataBodyRange
    dx = Application.Transpose(Tbl2.DataBodyRange)
    LastRow = Sheets("Таблица").ListObjects("Таблица1").ListRows.Count
    col = Tbl2.ListColumns("признак").Index
    For i = 1 To UBound(dx, 2)
        If dx(col, i) = признак Then
            For j = 1 To UBound(dx, 1)
            ReDim Preserve res(1 To UBound(dx, 1), 1 To pz)
                res(j, pz) = dx(j, i)
            Next j
            pz = pz + 1
            Sheets("Таблица").ListObjects("Таблица1").ListRows.Add
        End If
    Next
    Sheets("Таблица").ListObjects("Таблица1").ListRows(LastRow + 1).Range.Cells(1, 1).Resize(UBound(res, 2), UBound(res, 1)) = Application.Transpose(res)
Application.ScreenUpdating = True
End Sub

[/vba]
без Erase

Сообщение отредактировал jun - Пятница, 29.04.2022, 12:20

Ответить

Дата: Пятница, 29.04.2022, 12:57 | Сообщение № 15

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, спасибо,отлично

Ответить

Дата: Пятница, 29.04.2022, 13:12 | Сообщение № 16

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 141

Репутация: 42 ±

Замечаний: 0% ±

micholap_denis, еще хотел заметить, что код из сообщения 14 работает с массивами до 255 символов (ограничение application.transpose)
почитать можно тут:
https://excelvba.ru/code/Transpose
цитата: "Массив не может содержать элементов, длина которых превышает 255 знаков."

Ответить

Дата: Воскресенье, 01.05.2022, 22:10 | Сообщение № 17

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

jun, спасибо....блдьше 255 знаков не планируется))

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Смещение кнопок вниз после копирования строк макросом (Макросы/Sub)

Страница 1 из 1
1

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!