Копирование при фильтре - VBA

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

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

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование при фильтре - VBA (Макросы/Sub)

aastg2016

Дата: Пятница, 13.04.2018, 01:21 | Сообщение № 1

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

Ранг: Прохожий

Сообщений: 8

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

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

Excel 2016

Нужно при нажатии кнопки скопировать из листа даные на лист сводная таблица согласно числу смены и месяца.... Поидеи будет прежде делаться фильт по месяцу, так что месяц будет один, а вот числа и смены разные... как мне скопировать согласно фильтра, ибо там пропущеные строки при фильтрации (2,4,5- 3 пропущена) и оно должно выборку делать именно из отфильтрованного списка и копировать время согласно смены и числу...
и копировать должно построчно, не пойму ещё как люди делают функцию подсчета заполнености строки, а у меня будет куча поломок по сменно и должно скопировать тип поломки а время вставить согласно смены и числу... и в начале макроса необходимо очищать всю таблицу для того чтоб новые значения по фильтру не путались со старыми...
Вот есть что-то похожее, но оно копирует на листы... а мне надо с фильтра, с учетом пропущеных строк и согласно выборке
ПРИМЕР:
Option Explicit ' Обязательное объявление переменных
Option Compare Text ' отсутствие чувствительности к регистру при сравнении символов

Sub Raspredelenie_po_listam()
Const FirstRow& = 7 ' Константа - первая строка данных ниже шапки на всех листах
Dim i&, j&, LastRow&, LastRowTarget&, ShName, Sh_Target As Worksheet, Prefix$, FormulaRC$, A
Application.ScreenUpdating = False ' Временное отключение обновления экрана в Excel
For Each ShName In Array("Лист2", "Лист3", "Лист4") ' Цикл по 3 листам с результатами для очистки старых данных
With Sheets(ShName) ' Работа с объектом Sheet через символ "."
LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row ' Определение последней заполненной строки по столбцу Z
If LastRowTarget < FirstRow Then LastRowTarget = FirstRow ' последняя заполненная строка не должна быть меньше FirstRow (=7)
.Rows(FirstRow & ":" & LastRowTarget).Clear ' Удаление строк со старыми данными при новом распределении
End With
Next ShName
With Лист1 ' Работа с объектом Лист1 (программное имя объекта) через символ "."
LastRow = .Cells(.Rows.Count, "Z").End(xlUp).Row ' Определение последней заполненной строки по столбцу Z
Prefix = "=" & Лист1.Name & "!R" ' Первая часть ссылочных формул
A = .Range(.Cells(1, 1), .Cells(LastRow, 15)).Value ' Формируем массив для проверки условий
For i = FirstRow To LastRow ' Цикл по строкам анализируемого листа
A(i, 8) = Trim(A(i, 8)) ' удаление пробелов спереди и сзади в элементах 8-го столбца массива
A(i, 15) = Trim(A(i, 15))
If A(i, 8) = "ЗБС" Or A(i, 8) = "ВНС" Then ' Комплекс условий 1
Set Sh_Target = Лист2 ' Объектная ссылка на лист цель.
ElseIf (A(i, 8) = "Конс" Or A(i, 8) = "Раск") And A(i, 15) = "Я" Then ' Комплекс условий 2
Set Sh_Target = Лист3 ' Объектная ссылка на лист цель.
Else ' если не выполняется ни 1-ый ни 2-ой комлекс условий
Set Sh_Target = Лист4 ' Объектная ссылка на лист цель.
End If
.Range(.Cells(i, 1), .Cells(i, "AU")).Copy ' копирование i-той строки (по AU,для последующей вставки форматов)
FormulaRC = Prefix & Format(i) & "C" ' 2-я часть ссылочной формулы
With Sh_Target ' Работа с объектом листом-целью, куда копируем форматы, через символ "."
LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row + 1 ' Определение последней пустой строки по столбцу Z
If LastRowTarget < FirstRow Then LastRowTarget = FirstRow
.Cells(LastRowTarget, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' вставка скопированных форматов
.Rows(LastRowTarget).RowHeight = Лист1.Rows(i).RowHeight ' Выравнивание высоты строки по исходной
.Range(.Cells(LastRowTarget, 1), .Cells(LastRowTarget, "AU")).FormulaR1C1 = FormulaRC ' заполнение целевого диапазона ссылочными формулами
End With
Next i
End With
Set Sh_Target = Nothing ' Очистка памяти от объектных ссылок
End Sub

К сообщению приложен файл: 8919116.xlsx (12.4 Kb)

Ответить

СообщениеНужно при нажатии кнопки скопировать из листа даные на лист сводная таблица согласно числу смены и месяца.... Поидеи будет прежде делаться фильт по месяцу, так что месяц будет один, а вот числа и смены разные... как мне скопировать согласно фильтра, ибо там пропущеные строки при фильтрации (2,4,5- 3 пропущена) и оно должно выборку делать именно из отфильтрованного списка и копировать время согласно смены и числу...
и копировать должно построчно, не пойму ещё как люди делают функцию подсчета заполнености строки, а у меня будет куча поломок по сменно и должно скопировать тип поломки а время вставить согласно смены и числу... и в начале макроса необходимо очищать всю таблицу для того чтоб новые значения по фильтру не путались со старыми...
Вот есть что-то похожее, но оно копирует на листы... а мне надо с фильтра, с учетом пропущеных строк и согласно выборке
ПРИМЕР:
Option Explicit ' Обязательное объявление переменных
Option Compare Text ' отсутствие чувствительности к регистру при сравнении символов

Sub Raspredelenie_po_listam()
Const FirstRow& = 7 ' Константа - первая строка данных ниже шапки на всех листах
Dim i&, j&, LastRow&, LastRowTarget&, ShName, Sh_Target As Worksheet, Prefix$, FormulaRC$, A
Application.ScreenUpdating = False ' Временное отключение обновления экрана в Excel
For Each ShName In Array("Лист2", "Лист3", "Лист4") ' Цикл по 3 листам с результатами для очистки старых данных
With Sheets(ShName) ' Работа с объектом Sheet через символ "."
LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row ' Определение последней заполненной строки по столбцу Z
If LastRowTarget < FirstRow Then LastRowTarget = FirstRow ' последняя заполненная строка не должна быть меньше FirstRow (=7)
.Rows(FirstRow & ":" & LastRowTarget).Clear ' Удаление строк со старыми данными при новом распределении
End With
Next ShName
With Лист1 ' Работа с объектом Лист1 (программное имя объекта) через символ "."
LastRow = .Cells(.Rows.Count, "Z").End(xlUp).Row ' Определение последней заполненной строки по столбцу Z
Prefix = "=" & Лист1.Name & "!R" ' Первая часть ссылочных формул
A = .Range(.Cells(1, 1), .Cells(LastRow, 15)).Value ' Формируем массив для проверки условий
For i = FirstRow To LastRow ' Цикл по строкам анализируемого листа
A(i, 8) = Trim(A(i, 8)) ' удаление пробелов спереди и сзади в элементах 8-го столбца массива
A(i, 15) = Trim(A(i, 15))
If A(i, 8) = "ЗБС" Or A(i, 8) = "ВНС" Then ' Комплекс условий 1
Set Sh_Target = Лист2 ' Объектная ссылка на лист цель.
ElseIf (A(i, 8) = "Конс" Or A(i, 8) = "Раск") And A(i, 15) = "Я" Then ' Комплекс условий 2
Set Sh_Target = Лист3 ' Объектная ссылка на лист цель.
Else ' если не выполняется ни 1-ый ни 2-ой комлекс условий
Set Sh_Target = Лист4 ' Объектная ссылка на лист цель.
End If
.Range(.Cells(i, 1), .Cells(i, "AU")).Copy ' копирование i-той строки (по AU,для последующей вставки форматов)
FormulaRC = Prefix & Format(i) & "C" ' 2-я часть ссылочной формулы
With Sh_Target ' Работа с объектом листом-целью, куда копируем форматы, через символ "."
LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row + 1 ' Определение последней пустой строки по столбцу Z
If LastRowTarget < FirstRow Then LastRowTarget = FirstRow
.Cells(LastRowTarget, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' вставка скопированных форматов
.Rows(LastRowTarget).RowHeight = Лист1.Rows(i).RowHeight ' Выравнивание высоты строки по исходной
.Range(.Cells(LastRowTarget, 1), .Cells(LastRowTarget, "AU")).FormulaR1C1 = FormulaRC ' заполнение целевого диапазона ссылочными формулами
End With
Next i
End With
Set Sh_Target = Nothing ' Очистка памяти от объектных ссылок
End Sub

Автор - aastg2016
Дата добавления - 13.04.2018 в 01:21

Pelena

Дата: Пятница, 13.04.2018, 09:11 | Сообщение № 2