Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Скопировать макросом последние 3 строки видимого диапазона таблицы, Скопировать с учётом фильтров на другой лист
 
Здравствуйте!
Постоянно делаю одни и те же действия и будет разумно их "роботизировать").
Как копировать только три последние строки только видимого диапазона таблицы на Лист2?
Пробовал записать обычный макрос копировать/вставить, но при добавлении фильтров в таблице макрос берёт не то что выбрано, а всё подряд.
Как указать в макросе только видимые ячейки?
 
 
Код
i = 1
Do While ThisWorkbook.Sheets(1).Cells(i, 1) <> ""

i = i + 1
Loop

k = 1
i = i - 1
Do While i >= 2 And k <= 3
       If ThisWorkbook.Sheets(1).Rows(i).Hidden = False Then
                ThisWorkbook.Sheets(2).Cells(k, 1) = ThisWorkbook.Sheets(1).Cells(i, 1)
                ThisWorkbook.Sheets(2).Cells(k, 2) = ThisWorkbook.Sheets(1).Cells(i, 2)
                ThisWorkbook.Sheets(2).Cells(k, 3) = ThisWorkbook.Sheets(1).Cells(i, 3)
       k = k + 1
       End If
i = i - 1
Loop
Изменено: ProFessor - 16 Апр 2018 13:59:08
Вся проблема сложных программ, целых томов кодов и состоит в несоблюдении принципа лезвия Оккама: «Не следует множить сущее без необходимости».
Вся гениальность в простоте.
 
ProFessor, спасибо, то что нужно. А как перевернуть результат, чтобы выводило так как в таблице(нижняя строка была с низу)?  
 
Попробуйте так (P.S. я не компилировал, будет косяк - пишите)

Код
i = 1
Do While ThisWorkbook.Sheets(1).Cells(i, 1) <> ""
 
i = i + 1
Loop
 
k = 1
i = i - 1
n=4
Do While i >= 2 And k <= 3
       If ThisWorkbook.Sheets(1).Rows(i).Hidden = False Then
                ThisWorkbook.Sheets(2).Cells(n-k, 1) = ThisWorkbook.Sheets(1).Cells(i, 1)
                ThisWorkbook.Sheets(2).Cells(n-k, 2) = ThisWorkbook.Sheets(1).Cells(i, 2)
                ThisWorkbook.Sheets(2).Cells(n-k, 3) = ThisWorkbook.Sheets(1).Cells(i, 3)
       k = k + 1
       End If
i = i - 1
Loop
Вся проблема сложных программ, целых томов кодов и состоит в несоблюдении принципа лезвия Оккама: «Не следует множить сущее без необходимости».
Вся гениальность в простоте.
 
Код
Sub Macro1()
Dim LastRow As Long, i As Long, FreeRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    FreeRow = 3
    With Sheets("Лист2")
        For i = LastRow To 2 Step -1
            If Rows(i).Hidden = False Then
                Range(Cells(i, 1), Cells(i, 3)).Copy .Cells(FreeRow, 1)
                FreeRow = FreeRow - 1
                If FreeRow = 0 Then Exit Sub
            End If
        Next
    End With
End Sub
 
ProFessor, отлично работает, спасибо!
Юрий М, ругается на название "Лист2",  пишет ошибку"????2". Попробовал сменить на англ название, вообще ничего не происходит. 1 и 2 варианты справляются)
 
У меня не ругается. Выполнять следует при активном первом листе.
 
ProFessor, извините, но последний вопрос; как сделать так чтобы не брал заголовки таблицы?
Изменено: ser987 - 16 Апр 2018 21:50:35
 
ser987, а может Вы копировали код при англ. раскладке клавиатуры? В редакторе у Вас "Лист1" отображается или знаки вопроса?
 
Юрий М,  сейчас ещё раз попробовал запустить, всё работает !
наверно я что-то в первый раз накосячил) я до сего дня макросы записывал только мышкой)
спасибо!
 
"А сперва кричали, будто бракованный" (с) В. Высоцкий ))
 
Юрий М, может Вы знаете как сделать в первом макросе так чтобы не брал заголовки таблицы? ProFessor, видимо не в сети или устал от меня))
 
Лучше дождитесь его )
Страницы: 1
Читают тему (гостей: 1)