Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Скопировать ячейки A2:B5 в свободное место области печати - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Скопировать ячейки A2:B5 в свободное место области печати (Макросы/Sub)
Скопировать ячейки A2:B5 в свободное место области печати
latrodectus Дата: Четверг, 21.11.2019, 10:18 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Скопировать ячейки A2:B5 в свободное место области печати столько раз сколько указано в другой ячейке. В Примере вроде постарался все объяснить.
Печатать нужно много и в ручную получается много ошибок.
Постараюсь объяснить что должно быть на выходе. Есть клеевая бумага на подложке, бумага надрезана на 40 частей, 4 столбца и 10 строк.
Размер ячеек строго установлен и выверялся очень долго опытным путем и нужно чтобы скопированные ячейки вставлялись по четыре в стоку и переходили на следующую.
Как то так, пожалуйста помогите, а то уволят %)
К сообщению приложен файл: 0318527.xlsm (21.6 Kb)


Сообщение отредактировал latrodectus - Четверг, 21.11.2019, 10:19
 
Ответить
СообщениеСкопировать ячейки A2:B5 в свободное место области печати столько раз сколько указано в другой ячейке. В Примере вроде постарался все объяснить.
Печатать нужно много и в ручную получается много ошибок.
Постараюсь объяснить что должно быть на выходе. Есть клеевая бумага на подложке, бумага надрезана на 40 частей, 4 столбца и 10 строк.
Размер ячеек строго установлен и выверялся очень долго опытным путем и нужно чтобы скопированные ячейки вставлялись по четыре в стоку и переходили на следующую.
Как то так, пожалуйста помогите, а то уволят %)

Автор - latrodectus
Дата добавления - 21.11.2019 в 10:18
latrodectus Дата: Четверг, 21.11.2019, 11:35 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Появилось решение, но нужно чтобы при изменении копируемых ячеек список не обновлялся при нажатии кнопки Вставить, а продолжался вниз.
К сообщению приложен файл: 6907567.xlsm (24.8 Kb)
 
Ответить
СообщениеПоявилось решение, но нужно чтобы при изменении копируемых ячеек список не обновлялся при нажатии кнопки Вставить, а продолжался вниз.

Автор - latrodectus
Дата добавления - 21.11.2019 в 11:35
boa Дата: Четверг, 21.11.2019, 17:35 | Сообщение № 3
Группа: Друзья
Ранг: Ветеран
Сообщений: 550
Репутация: 167 ±
Замечаний: 0% ±

365
latrodectus,
Наверное так:
Очистку закоментить, а rw переприсвоить
[vba]
Код
'    Cells(rw, "A").CurrentRegion.Clear
    If Not IsEmpty(Cells(rw, "A")) Then rw = Cells(Rows.Count, "A").End(xlUp).Row + 1
[/vba]


 
Ответить
Сообщениеlatrodectus,
Наверное так:
Очистку закоментить, а rw переприсвоить
[vba]
Код
'    Cells(rw, "A").CurrentRegion.Clear
    If Not IsEmpty(Cells(rw, "A")) Then rw = Cells(Rows.Count, "A").End(xlUp).Row + 1
[/vba]

Автор - boa
Дата добавления - 21.11.2019 в 17:35
RAN Дата: Четверг, 21.11.2019, 21:04 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
Sub Test3()
    Dim r As Range, i1&, i2&, rw&, cl&: rw = 20: cl = 1
    Dim cell As Range
    Set cell = Cells.Find("*", , , , xlByRows, xlPrevious)
    If cell.Row > rw Then
        If cell.Column >= 8 Then
            rw = cell.Row + 1
            cl = 1
        Else
            rw = cell.Row - 3
            cl = cell.Column + 1
        End If
    End If
    Set r = Range("E1").CurrentRegion
    Application.ScreenUpdating = False
    '    Cells(rw, "A").CurrentRegion.Clear
    For i1 = 2 To r.Rows.Count
        Range("C4") = r(i1, 1)
        For i2 = 1 To r(i1, 2)
            Range("B2:C5").Copy Cells(rw, cl)
            If cl = 7 Then
                cl = 1: rw = rw + 4
            Else: cl = cl + 2: End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
Sub Test3()
    Dim r As Range, i1&, i2&, rw&, cl&: rw = 20: cl = 1
    Dim cell As Range
    Set cell = Cells.Find("*", , , , xlByRows, xlPrevious)
    If cell.Row > rw Then
        If cell.Column >= 8 Then
            rw = cell.Row + 1
            cl = 1
        Else
            rw = cell.Row - 3
            cl = cell.Column + 1
        End If
    End If
    Set r = Range("E1").CurrentRegion
    Application.ScreenUpdating = False
    '    Cells(rw, "A").CurrentRegion.Clear
    For i1 = 2 To r.Rows.Count
        Range("C4") = r(i1, 1)
        For i2 = 1 To r(i1, 2)
            Range("B2:C5").Copy Cells(rw, cl)
            If cl = 7 Then
                cl = 1: rw = rw + 4
            Else: cl = cl + 2: End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - RAN
Дата добавления - 21.11.2019 в 21:04
latrodectus Дата: Пятница, 22.11.2019, 06:33 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо огромное ещё раз и форуму в том числе. Если кому интересно - вот что получилось, даже лучше чем я ожидал!!!
К сообщению приложен файл: 5623192.xlsm (35.1 Kb)
 
Ответить
СообщениеСпасибо огромное ещё раз и форуму в том числе. Если кому интересно - вот что получилось, даже лучше чем я ожидал!!!

Автор - latrodectus
Дата добавления - 22.11.2019 в 06:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Скопировать ячейки A2:B5 в свободное место области печати (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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