Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Разделить таблицу на отдельные листы
 
Добрый день, просьба помочь с разделением таблицы со значениями на отдельные листы

Пример приложил: желтый цвет - исходная таблица со значениями; зеленые листы - хочу получить результат в результате парсинга
 
Код
Sub Step1()
    Dim y As Long
    Dim a As Variant
    Dim s1 As String
    Dim s2 As String
    
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Исходные данные")
    With sh1
        y = .Cells(Rows.Count, 2).End(xlUp).Row
        a = .Range(.Cells(2, 1), .Cells(y, 4))
    End With
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    For y = LBound(a, 1) To UBound(a, 1)
        Select Case a(y, 1)
        Case ""
            Select Case a(y, 2)
            Case "Состав звена:", "Машины и механизмы:", "Материалы:"
                s2 = a(y, 2)
                Set dic.Item(s1).Item(s2) = CreateObject("Scripting.Dictionary")
            Case Else
                dic.Item(s1).Item(s2).Item(a(y, 2)) = dic.Item(s1).Item(s2).Item(a(y, 2)) + a(y, 3)
            End Select
        Case Else
            s1 = a(y, 2)
            Set dic.Item(s1) = CreateObject("Scripting.Dictionary")
        End Select
    Next
    
    Step2 dic
    Step3 dic, "Состав звена"
    Step3 dic, "Машины и механизмы"
    Step3 dic, "Материалы"
End Sub
Sub Step2(dic As Dictionary)
    Dim sh As Worksheet
    On Error Resume Next
        Const s = "Общие сведения"
        Application.DisplayAlerts = False
        Worksheets(s).Delete
        Application.DisplayAlerts = True
        Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
        sh.Name = s
    On Error GoTo 0
    sh.Cells(1, 1).Value = "наименование"
    sh.Cells(2, 1).Resize(dic.Count) = Application.Transpose(dic.Keys())
End Sub
Sub Step3(dic As Dictionary, s)
    Dim sh As Worksheet
    On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(s).Delete
        Application.DisplayAlerts = True
        Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
        sh.Name = s
    On Error GoTo 0
    sh.Cells(1, 1).Resize(1, 3) = Array("наименование", " ", "количество")
    Dim v1 As Variant
    Dim v2 As Variant
    Dim y As Long
    y = 2
    For Each v1 In dic.Keys
        If dic.Item(v1).Exists(s & ":") Then
            For Each v2 In dic.Item(v1).Item(s & ":").Keys
                sh.Cells(y, 1).Value = v1
                sh.Cells(y, 2).Value = v2
                sh.Cells(y, 3).Value = dic.Item(v1).Item(s & ":").Item(v2)
                y = y + 1
            Next
        End If
    Next
    sh.UsedRange.EntireColumn.AutoFit
End Sub
 
Решение.
Изменено: skais675 - 13 Ноя 2019 14:11:56
 
пока что то не совсем понятно, как применить два решения

в первом случае от МатросНаЗебре - макрос не сработал. Можете по подробней описать
во втором случае - автоматический перерасчет не сработал
 
dem59 Что именно не сработало? Жмите кнопку.
Изменено: skais675 - 13 Ноя 2019 14:05:54
 
Добавил новую запись, по кнопке автоматом заполнился Лист @Source@. На остальных листах пришлось руками добавлять в фильтр новую запись. а хотелось бы получить автоматически все листы.  
 
dem59, файл поправил, пробуйте.
 
Цитата
dem59 написал:
можете подсказать последовательность выполнения макроса.  
Нужно скопировать макросы в файл и запустить макрос  Step1.
 
Сделал, при запуске выдает ошибку  
Ошибка.jpg (56.17 КБ)
 
Цитата
skais675 написал:
файл поправил, пробуйте
Супер, сижу тестирую, спасибо. еще б понять как сделали
 
Замените Dictionary на Object
Код
Sub Step2(dic As Object)
Sub Step3(dic As Object, s)
 
skais675 ? МатросНаЗебре возможно сделать как то универсально?

Приложил пример с другими параметрами. Этих параметров может n
 
Цитата
dem59 написал:
skais675  написал:файл поправил, пробуйте
а можно сделать более универсальное решение для других параметров
 
dem59, я сейчас закрою тему. Пункт 3.6 правил.
 
Прошу прощения, понял тему закрываю тогда
Цитата
Юрий М написал:
я сейчас закрою тему.
Прошу прощения, тема закрыта
Страницы: 1
Читают тему (гостей: 1)
Наверх