Страницы: 1
RSS
Макрос_горизонтальная фильтрация. Распознать блоки с разными числами и разделил их.
 
Добрый день! Прошу подсказать макрос для файла во вложении. На листе 1 и 2 исходные данные. На листе Итог - требуемая таблица. Колонка С на листе 1 может содержать большое кол-во значений. Шаг между числами любой. Главное чтобы макрос распознавал блоки с разными числами и делил их.
Над каждым блоком должна быть стандартная шапка, внизу блока тоже. И главное фильтры. Регион и формат всегда должен быть от меньшего к большему. Кол-во строк и столбцов может быть разное. Если есть идеи как это сделать пусть и несколькими макросами - прошу подсказать. Руками уже замучался делать. Особенно когда под 80 блоков.
 
Андрей Неизвестный, дд. попробуйте (сделал как понял) без каких-то фильтрOV
Код
Sub sdsd()
Dim i As Long, lr As Long, cell As Range, sh2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set sh2 = Worksheets("Лист2")
With Worksheets("Лист1")
For i = lr To 2 Step -1
x = Application.WorksheetFunction.CountIf(.Columns(3), .Cells(i, 3))
' строки план/факт/разница
.Rows(i + 1 & ":" & i + 3).EntireRow.Insert
.Cells(i + 1, 5) = "Факт": .Cells(i + 2, 5) = "План": .Cells(i + 3, 5) = "Разница"
Set cell = sh2.Columns(1).Find(.Cells(i, 3))
sh2.Range(sh2.Cells(cell.Row + 1, 2), _
sh2.Cells(cell.Row + 1, 11)).Copy Destination:=.Cells(i + 2, 6)
    For k = 6 To 15
        .Cells(i + 1, k) = Application.WorksheetFunction.CountA(Range(.Cells(i, k), .Cells(i - x + 1, k)))
        .Cells(i + 3, k) = .Cells(i + 2, k) - .Cells(i + 1, k)
    Next k
'строки шапка/формат/регион/город
'провеярем не первая ли строка у нас так как шапку уже есть
If i - x = 1 Then
    .Rows("1:3").EntireRow.Insert
    .Cells(i - 3, 5) = "Город": .Cells(i - 4, 5) = "Регион": .Cells(i - 5, 5) = "Формат"
    sh2.Range("B2:K2").Copy Destination:=.Cells(i - 3, 6)
    sh2.Range("B1:K1").Copy Destination:=.Cells(i - 4, 6)
    sh2.Range(sh2.Cells(cell.Row, 2), sh2.Cells(cell.Row, 11)).Copy Destination:=.Cells(i - 5, 6)
Else
    .Rows(i - x + 1 & ":" & i - x + 5).EntireRow.Insert
    .Rows(1).Copy Destination:=.Rows(i - x + 5)
    .Cells(i - x + 4, 5) = "Город": .Cells(i - x + 3, 5) = "Регион": .Cells(i - x + 2, 5) = "Формат"
    sh2.Range("B2:K2").Copy Destination:=.Cells(i - x + 4, 6)
    sh2.Range("B1:K1").Copy Destination:=.Cells(i - x + 3, 6)
    sh2.Range(sh2.Cells(cell.Row, 2), sh2.Cells(cell.Row, 11)).Copy Destination:=.Cells(i - x + 2, 6)
End If
i = i - x + 1
Next i
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 28.09.2020 16:08:52
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, спасибо! в общем и целом то, что я хотел. Вставил другую таблицу. Шапки макрос расставил правильно, кроме самой первой, её он засунул посередине таблицы с данными. В какой строке можно изменить данные, чтобы макрос считал не 10 столбиков, а, например, 150? И можно ли формулы из строки Факт и Разница сделать чтобы они остались формулами, а не были преобразованы в значение?
 
Цитата
Андрей Неизвестный написал:
В какой строке можно изменить данные, чтобы макрос считал не 10 столбиков, а, например, 150?
вот тут
Цитата
Mershik написал:
For k = 6 To 15
Цитата
Андрей Неизвестный написал:
И можно ли формулы из строки Факт и Разница сделать чтобы они остались формулами, а не были преобразованы в значение?
можно
Не бойтесь совершенства. Вам его не достичь.
 
Изменил кол-во колонок. Вылезает ошибка. Красным выделил. Понять не могу что не так. Это же в третью строку после таблицы поставить формулу строка 1 минус строка 2? А что ему не нравится то...не пойму
Код
For k = 6 To 142
        .Cells(i + 1, k) = Application.WorksheetFunction.CountA(Range(.Cells(i, k), .Cells(i - x + 1, k)))
        .Cells(i + 3, k) = .Cells(i + 2, k) - .Cells(i + 1, k)
Next k
 
Андрей Неизвестный, покажите в файле с учетом исправленй
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, я понял в чём дело. До этого я запускал макрос на других файлах. Попробовал запустить на файле с примером, который высылал. Вижу теперь что не так. Во втором блоке шапку ставит правильно. У первого идет смещение. Шапка первого блока смещена на 1 строку ниже, чем надо. Скорее всего поэтому и в моем другом файле возникает некий конфликт. В первом блоке, видимо, из-за смещения шапки и горизонтальный фильтр не сработал.
 
Решил проблему. Методом тыка. Теперь шапку для верхнего блока ставит правильно. Теперь фильтр горизонтальный не работает. Придется опять метод тыка включать
Код
If i - x = 1 Then
    .Rows("1:3").EntireRow.Insert
    .Cells(3, 5) = "Ãîðîä": .Cells(2, 5) = "Ðåãèîí": .Cells(1, 5) = "Ôîðìàò"
    sh2.Range("B2:EA2").Copy Destination:=.Cells(3, 6)
    sh2.Range("B1:EA1").Copy Destination:=.Cells(2, 6)
    sh2.Range(sh2.Cells(cell.Row, 2), sh2.Cells(cell.Row, 131)).Copy Destination:=.Cells(1, 6)
 
Вы можете менять что хотите,но без файла-примера в РЕАЛЬНОЙ СТРУКТУРЕ, тяжело что-то поменять правильно, а тратить время и менять наугад мне не Хочется
Изменено: Mershik - 04.10.2020 21:57:01
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Добрый день! Я немного не про то говорил. Не заметил в первом ответе, что макрос написан без фильтров. Думал, что он не работает, потому что у меня диапазон таблицы другой, хотел сам подогнать. Как сделать горизонтальную фильтрацию блоков? Пример данных есть в файле в первом письме. Регион должен быть всегда от меньшего к большему, потом формат.
Страницы: 1
Наверх