Страницы: 1
RSS
удалить столбцы по наименованиям, применить фильтры по строкам
 
Добрый день!
В файле на листе 1 необходимо найти столбцы содержащие в названии Промо5 и Промо6 - и удалить их.
Применить фильтр в колонках Промо2, Промо3 и Промо по значениям: Л1+S103+0 соответственно, скопировать поучившуюся таблицу и вставить на Лист 2, без первой пустой строки.
Количество строк и колонок может постоянно меняться.
Знаю как сделать используя Select и Activate, но если данных много - макрос виснет((
Спасибо за помощь.
 
Код
Option Explicit

Sub filter()
Dim lr As Long
Dim lc As Long
Dim i, a, b, d, c
Dim ac As Long
Dim bc As Long
Dim dc As Long

lr = Sheets("лист1").Cells(Rows.Count, 2).End(xlUp).Row
lc = Sheets("лист1").Cells(2, Columns.Count).End(xlToLeft).Column

For i = lc To 1 Step -1
  If Worksheets("лист1").Cells(2, i).Value Like LCase("промо5") Or Worksheets("лист1").Cells(2, i).Value Like LCase("промо6") Then
    Cells(2, i).EntireColumn.Delete
  End If
Next
With Worksheets("лист1").Rows("2:2")
Set a = .find(What:=LCase("промо2"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
ac = a.Column

Set b = .find(What:=LCase("промо3"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
bc = b.Column
Set d = .find(What:=LCase("промо"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
dc = d.Column
End With

lc = Sheets("лист1").Cells(2, Columns.Count).End(xlToLeft).Column
For i = 1 To lc
 Worksheets("Лист2").Cells(1, i).Value = Worksheets("лист1").Cells(2, i).Value
Next
c = 2

For i = 3 To lr
  If Worksheets("лист1").Cells(i, ac).Value = LCase("л1") And _
  Worksheets("лист1").Cells(i, bc).Value = "S103" And _
  Worksheets("лист1").Cells(i, dc).Value = "0" Then
  Worksheets("Лист2").Rows(c).Value = Worksheets("лист1").Rows(i).Value
  c = c + 1
  End If
Next
End Sub
Изменено: Hellmaster - 15.10.2019 16:18:35
 
На Лист2 вставились только названия столбцов, остальные данные не перенеслись
 
У меня полностью работает макрос
 
Да, в Вашем файле все работает) спасибо
Страницы: 1
Наверх