Парсер дерева в excel с выводом в форму на другом листе

@belka-letyaga · Регистрация: 30.10.2013

Студворк — интернет-сервис помощи студентам

Здравствуйте, друзья.

В программировании у меня навыки стремятся к нулю, но очень хочется освоить.

Сейчас пытаюсь автоматизировать задачу:
в excel есть выгрузка из БД, которая замечательно раскладывается по столбцам

пример по ссылке гугл докс https://docs.google.com/spread... sp=sharing

Задача, чтоб из этой выгрузки данные складывались по форме (представленной на втором листе)

Очень криворученько пытаюсь обработать один столбик. да и то не выходит...
Программирования не было у меня ни в школе, ни в инсте, только, только начал.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
For i = 6 To 999
Sheets("T-UD597142").Select
Set obj = Worksheets(1).Range("D1:D999").Find(What:="?", LookIn:=xlValues, LookAt:=xlPart, SearchFormat:=False)
If Not obj Is Nothing Then
        With obj.Select
            Selection.Copy
            Sheets("list2").Select
            Cells(i, 9).Select
            ActiveSheet.Paste
            
        End With
Set obj = Nothing
    End If

Добавлено через 11 минут
понимаю. что алгоритм должен быть типа:
смотрим 1 столбик - нашли значение, добавили ячейку с именем - записали форму, дальше
пока в первом пусто смотрим 2 столбик - нашли значение - записали в форму, дальше
пока во втором пусто смотрим 3 столбик - нашли значение, добавили ячейку с именем - записали в форму, дальше
пока во третьем пусто смотрим 4 и 5 столбик - нашли значение - записали в форму, дальше

Добавлено через 12 минут
прошу подсказать, какой алгоритм и функции в VBA использовать
ибо знаком крайне поверхностно

@Hugo121 · 30.10.2013, 13:42

Трудно понять структуру, когда все значения одинаковы.
Сделайте другой файл, и сюда его, согласно правил.

@belka-letyaga · 30.10.2013, 14:30 **[ТС]**

Вот исходный файл

В листе2 форма в которую вставляется (там строчка с адресами

и шаблон оформления

В принципе, я понимаю, что можно замакросить первую таблицу, чтобы получалась похожая форма, но хочется именно алгоритм обхода дерева написать.

Аксима · 31.10.2013, 15:42

Здравствуйте, belka-letyaga,

Вашу задачу сделал в два этапа:

1) Построение дерева на основании данных с основного листа.

2) Анализ дерева и вывод полученных табичных данных в форму.

Ниже привожу листинги для каждой подзадачи:

Построение дерева

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
'Процедура собирает разбросанные по листу данные в стройную древовидную структуру.
Sub MakeTree(ByVal ChaoticData As Range, _
ByRef Tree() As Variant, ByRef TreeTF() As Variant, _
ByRef SizeM As Long, ByRef SizeN As Long, ByRef SizeK As Long)
    Dim arr As Variant, dic As Object, dKeys As Variant
    Dim i As Long, j As Long, n As Long, m As Long, k As Long
    Dim r As Long, c As Long, cOne As Long
    arr = ChaoticData
    r = UBound(arr)
    c = UBound(arr, 2)
    ReDim arr1(1 To r, 1 To c) As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To r
        n = 0
        'Считаем количество разбросанных по строке значений.
        For j = 1 To c
            If Not IsEmpty(arr(i, j)) Then
                n = n + 1
                'Если в строке массива arr есть хотя бы одно непустое значение -
                '- заносим его в элемент массива arr1, индекс столбца которого
                'соответствует индексу столбца непустого значения из массива arr.
                If n = 1 Then
                    k = k + 1
                    cOne = j
                    dic(j) = 0&
                    arr1(k, cOne) = arr(i, j)
                End If
                'Если, кроме первого, в массиве arr есть еще другие непустые
                'значения - присоединяем их к первому заполненному элементу
                'в массиве arr1.
                If n > 1 Then
                    arr1(k, cOne) = arr1(k, cOne) & ";" & arr(i, j)
                End If
            End If
        Next j
    Next i
    'Дерево почти готово, но нужно убрать пустые столбцы.
    n = dic.Count
    dKeys = dic.Keys
    ReDim Tree(1 To k, 1 To n) As Variant
    ReDim TreeTF(1 To k, 1 To n) As Variant
    For i = 1 To k
        For j = 1 To n
            Tree(i, j) = arr1(i, dKeys(j - 1))
        Next j
        If Not IsEmpty(arr1(i + n - 1, dKeys(n - 1))) Then
            m = m + 1
            For j = 1 To n
                TreeTF(m, j) = arr1(i + j - 1, dKeys(j - 1))
            Next j
        End If
    Next i
    SizeM = m
    SizeN = n
    SizeK = k
End Sub

Анализ дерева + вывод результатов

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
'Процедура анализа дерева.
Sub TreeParser()
    Const srcName = "T-UD597142"
    Dim dic As Object
    Dim shSrc As Worksheet, shTree As Worksheet, shTable As Worksheet, rng As Range
    Dim i As Long, j As Long, m As Long, n As Long, k As Long, s As String
    Dim t() As Variant, t_tbl() As Variant, tbl() As Variant, v As Variant
    v = Array("", "_Дерево", "_Форма")
    On Error GoTo ErrSheetNotExists
        For i = 0 To 2
            s = srcName & v(i)
            Select Case i
                Case 0: Set shSrc = Sheets(s)
                Case 1: Set shTree = Sheets(s)
                Case 2: Set shTable = Sheets(s)
            End Select
        Next i
    On Error GoTo 0
    Set rng = shSrc.Range(shSrc.Range("C4"), shSrc.Cells.SpecialCells(xlCellTypeLastCell))
    MakeTree rng, t, t_tbl, m, n, k
    shTree.Cells.Clear
    shTree.Range("C4").Resize(k, n) = t
    For j = 1 To n
        For i = 1 To m
            If IsEmpty(t_tbl(i, j)) Then t_tbl(i, j) = v Else v = t_tbl(i, j)
        Next i
    Next j
    v = Array("Номер полномочия", "Объект полномочий", "Имя объекта полномочий", "Поле полномочий", "Имя поля полномочий", "Значение начальное", "Значение конечное")
    k = UBound(v)
    ReDim tbl(m - 1, k) As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    dic.Add 0, Array(3, True, 0)
    dic.Add 1, Array(2, True, 0)
    dic.Add 2, Array(2, True, 2)
    dic.Add 3, Array(4, True, 0)
    dic.Add 4, Array(4, True, 2)
    dic.Add 5, Array(5, False, 0)
    For i = 0 To m - 1
        For j = 0 To k - 1
            tbl(i, j) = t_tbl(i + 1, dic(j)(0))
            If dic(j)(1) Then tbl(i, j) = Split(tbl(i, j), ";")(dic(j)(2))
        Next j
        tbl(i, k) = 0
    Next i
    shTable.Cells.Clear
    shTable.Cells(4, 2).Resize(m, k + 1) = tbl
    shTable.Rows(3).RowHeight = 51.75
    With shTable.Cells(3, 2).Resize(, k + 1)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.25
        .Borders.Weight = xlMedium
        .Value = v
        .EntireColumn.AutoFit
    End With
    Exit Sub
 
ErrSheetNotExists:
    If s <> srcName Then
        With Sheets
            .Add(After:=.Item(.Count)).Name = s
        End With
        Resume
    Else
        MsgBox "Отсутствует лист с исходными данными" & vbCr & _
        "(лист " & srcName & ")." & vbCr & _
        "Продолжение работы невозможно."
        Err.Clear
    End If
End Sub

С уважением,

Aksima

@belka-letyaga · 31.10.2013, 17:20 **[ТС]**

Вот это класс!!!

Всё, до чего я смог дойти, и то с помощью коллеги, это вышеупомянутое макросанье, и допиливание ручками.

А представленный вариант - просто чудо, и комменты класс, ещё не разобрался до конца, правда, но попробую модифицировать код для другого исходника и формы.

наши костыли (к дереву не относящиеся)(для работы нужно было ручками подредактировать исходничек сначала, а потом ещё руками удалить строки с пустыми значениями операций и скопировать всё это по столбцам в форму):

макросанье

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub m123()
    
    Dim x As Integer
    Dim y As Integer
    Dim i As Integer
    x = 0
    y = 2
    
    Do While x < 8
        x = x + 1
        If x = 4 Then
          x = 6
        End If
        y = 1
        i = 1
            
        Do
            If Cells(y + i, 1) = "" And Cells(y + i, 2) = "" And Cells(y + i, 3) = "" And Cells(y + i, 4) = "" And Cells(y + i, 5) = "" And Cells(y + i, 6) = "" And Cells(y + i, 7) = "" And Cells(y + i + 1, 1) = "" And Cells(y + i + 1, 2) = "" And Cells(y + i + 1, 3) = "" And Cells(y + i + 1, 4) = "" And Cells(y + i + 1, 5) = "" And Cells(y + i + 1, 6) = "" And Cells(y + i + 1, 7) = "" And Cells(y + i + 2, 1) = "" And Cells(y + i + 2, 2) = "" And Cells(y + i + 2, 3) = "" And Cells(y + i + 2, 4) = "" And Cells(y + i + 2, 5) = "" And Cells(y + i + 2, 6) = "" And Cells(y + i + 2, 7) = "" Then
                Exit Do
            End If
            y = y + i
            i = 1
            Do While Cells(y + i, x).Value = ""
                If Cells(y + i, 1) = "" And Cells(y + i, 2) = "" And Cells(y + i, 3) = "" And Cells(y + i, 4) = "" And Cells(y + i, 5) = "" And Cells(y + i, 6) = "" And Cells(y + i, 7) = "" And Cells(y + i + 1, 1) = "" And Cells(y + i + 1, 2) = "" And Cells(y + i + 1, 3) = "" And Cells(y + i + 1, 4) = "" And Cells(y + i + 1, 5) = "" And Cells(y + i + 1, 6) = "" And Cells(y + i + 1, 7) = "" And Cells(y + i + 2, 1) = "" And Cells(y + i + 2, 2) = "" And Cells(y + i + 2, 3) = "" And Cells(y + i + 2, 4) = "" And Cells(y + i + 2, 5) = "" And Cells(y + i + 2, 6) = "" And Cells(y + i + 2, 7) = "" Then
                    Exit Do
                End If
                Cells(y + i, x).Value = Cells(y, x).Value
            i = i + 1
            Loop
        Loop
    Loop
End Sub

@Hugo121 · 31.10.2013, 18:55

Вот эту кучу

and проверка and проверка and проверка

я советую заменить на кучу

if проверка then
if проверка then
if проверка then

end if
end if
end if

Taк не надо будет тратить лишнее время на провеку всех условий, когда уже первое не подходит.
Ну и конечно стОит первыми проверять найболее маловероятные.
Тем более что работаете с ячейками, а не с массивом данных - что и так уже медленно.

Новые блоги и статьи Все статьи Все блоги /
[Owen Logic] Поддержание уровня воды в резервуаре количеством включённых насосов: моделирование и выбор регулятора ФедосеевПавел 14.03.2026 Поддержание уровня воды в резервуаре количеством включённых насосов: моделирование и выбор регулятора ВВЕДЕНИЕ Выполняя задание на управление насосной группой заполнения резервуара,. . .	делаю науч статью по влиянию грибов на сукцессию anaschu 13.03.2026 прикрепляю статью	SDL3 для Desktop (MinGW): Создаём пустое окно с нуля для 2D-графики на SDL3, Си и C++ 8Observer8 10.03.2026 Содержание блога Финальные проекты на Си и на C++: hello-sdl3-c. zip hello-sdl3-cpp. zip Результат:	Установка CMake и MinGW 13.1 для сборки С и C++ приложений из консоли и из Qt Creator в EXE 8Observer8 10.03.2026 Содержание блога MinGW - это коллекция инструментов для сборки приложений в EXE. CMake - это система сборки приложений. Здесь описаны базовые шаги для старта программирования с помощью CMake и. . .
Как дизайн сайта влияет на конверсию: 7 решений, которые реально повышают заявки Neotwalker 08.03.2026 Многие до сих пор воспринимают дизайн сайта как “красивую оболочку”. На практике всё иначе: дизайн напрямую влияет на то, оставит человек заявку или уйдёт через несколько секунд. Даже если у вас. . .	Модульная разработка через nuget packages DevAlt 07.03.2026 Сложившийся в . Net-среде способ разработки чаще всего предполагает монорепозиторий в котором находятся все исходники. При создании нового решения, мы просто добавляем нужные проекты и имеем. . .	Модульный подход на примере F# DevAlt 06.03.2026 В блоге дяди Боба наткнулся на такое определение: В этой книге («Подход, основанный на вариантах использования») Ивар утверждает, что архитектура программного обеспечения — это структуры,. . .	Управление камерой с помощью скрипта OrbitControls.js на Three.js: Вращение, зум и панорамирование 8Observer8 05.03.2026 Содержание блога Финальная демка в браузере работает на Desktop и мобильных браузерах. Итоговый код: orbit-controls-threejs-js. zip. Сканируйте QR-код на мобильном. Вращайте камеру одним пальцем,. . .

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	30.10.2013, 13:42
	Трудно понять структуру, когда все значения одинаковы. Сделайте другой файл, и сюда его, согласно правил. 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	31.10.2013, 18:55
	Вот эту кучу and проверка and проверка and проверка я советую заменить на кучу if проверка then if проверка then if проверка then end if end if end if Taк не надо будет тратить лишнее время на провеку всех условий, когда уже первое не подходит. Ну и конечно стОит первыми проверять найболее маловероятные. Тем более что работаете с ячейками, а не с массивом данных - что и так уже медленно. 0