Преобразовать таблицу

@Holmarkland · Регистрация: 24.10.2024

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

Добрый день, помогите с написанием макроса для преобразования таблицы.
Существует исходная таблица с периодом технического обслуживания. Есть оборудование, у каждого уникальный номер.
Есть оборудование у которого только ТО1 (одна строка), есть оборудование у которого только ТО1 и ТО2 (две строки) и есть оборудование у которого ТО1, ТО2 и ТО3 (3 строки)

Сейчас график представлен в виде, где у одного прибора ТО прописано в разных строках. ТО1 в первой строке, ТО2 во второй строке и ТО3 в третьей строке. Мне необходимо сделать, так чтобы все виды ТО были только в первой строке (или одинаково в каждой).
как в примерах Ver.1 либо Ver.2, в зависимости от того, как сделать проще - скопировать значения выше и ниже или сдвинуть вверх

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

@АЕ · 24.10.2024, 16:21

Holmarkland, а возможно, что в один месяц для одного изделия сразу 2 или 3 ТО?

@Jamaica · 24.10.2024, 16:42

Во вложении файл "Уплотнитель.xlsm" в архиве zip,
скопируйте его в папку с файлом примера (График ТО),
и откройте.
И модифицируйте под рабочий файл и другие потребности.

@Holmarkland · 24.10.2024, 17:03 **[ТС]**

Нет, такое исключено

Добавлено через 10 минут
Нет, такое исключено

@Angry Old Man · 24.10.2024, 17:54

Holmarkland, Что исключено? Несколько ТО в одном месяце?
Вот мой макрос, на всякий случай учел и такое.

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
Option Explicit
 
Sub GrafTO()
 
Const R1 = "A5"
ActiveSheet.Copy , Sheets(Worksheets.Count)
ActiveSheet.Name = CStr(Replace(Now, ":", "."))
 
Dim R, SN, M, MM, i
 
Set R = Range(R1)
SN = CStr(R)
With CreateObject("Scripting.Dictionary")
    Do While Trim(SN) <> ""
        SN = CStr(R)
        If Not .Exists(SN) Then
            M = R.Resize(1, 13)
            M(1, 1) = SN
            .Add CStr(SN), M
        Else
            M = .Item(SN)
            MM = R.Resize(1, 13)
            For i = 2 To 13
                If MM(1, i) <> "" Then
                    If M(1, i) = "" Then M(1, i) = MM(1, i) Else M(1, i) = M(1, i) & "," & MM(1, i)
                    .Item(SN) = M
                End If
            Next
        End If
        Set R = R.Offset(1, 0)
        SN = CStr(R)
    Loop
    
    Set R = Range(R1)
    For Each SN In .Keys()
        R.Resize(1, 13) = .Item(SN)
        Set R = R.Offset(1, 0)
    Next
End With
Range(R.Address & ":" & Split(ActiveSheet.UsedRange.Address, ":")(1)).Clear
 
End Sub

В книге создаётся новый лист, где оставлены уникальные строки с номерами и в строке - все ТО
Файлы прилагаю. Единственное, если это нужно, отформатируйте исходный столбец как текст

@Holmarkland · 24.10.2024, 18:05 **[ТС]**

Сообщение от Jamaica

Во вложении файл "Уплотнитель.xlsm" в архиве zip,
скопируйте его в папку с файлом примера (График ТО),
и откройте.
И модифицируйте под рабочий файл и другие потребности.

Спасибо огромное, не только круто работает, но и имеет крутое название

Добавлено через 27 секунд

Сообщение от Angry Old Man

Holmarkland, Что исключено? Несколько ТО в одном месяце?
Вот мой макрос, на всякий случай учел и такое.

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
Option Explicit
 
Sub GrafTO()
 
Const R1 = "A5"
ActiveSheet.Copy , Sheets(Worksheets.Count)
ActiveSheet.Name = CStr(Replace(Now, ":", "."))
 
Dim R, SN, M, MM, i
 
Set R = Range(R1)
SN = CStr(R)
With CreateObject("Scripting.Dictionary")
    Do While Trim(SN) <> ""
        SN = CStr(R)
        If Not .Exists(SN) Then
            M = R.Resize(1, 13)
            M(1, 1) = SN
            .Add CStr(SN), M
        Else
            M = .Item(SN)
            MM = R.Resize(1, 13)
            For i = 2 To 13
                If MM(1, i) <> "" Then
                    If M(1, i) = "" Then M(1, i) = MM(1, i) Else M(1, i) = M(1, i) & "," & MM(1, i)
                    .Item(SN) = M
                End If
            Next
        End If
        Set R = R.Offset(1, 0)
        SN = CStr(R)
    Loop
    
    Set R = Range(R1)
    For Each SN In .Keys()
        R.Resize(1, 13) = .Item(SN)
        Set R = R.Offset(1, 0)
    Next
End With
Range(R.Address & ":" & Split(ActiveSheet.UsedRange.Address, ":")(1)).Clear
 
End Sub

В книге создаётся новый лист, где оставлены уникальные строки с номерами и в строке - все ТО
Файлы прилагаю. Единственное, если это нужно, отформатируйте исходный столбец как текст

Спасибо большое, ваш способ тоже отлично работает )

@Angry Old Man · 24.10.2024, 19:11

Holmarkland,

Сообщение от Holmarkland

не только круто работает, но и имеет крутое название

Завидую молча. Но предлагаю иной подход:

делаем VBS-скрипт в удобном месте

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
Option Explicit
 
Dim XLS                     '''''': XLS = "D:\Мой контент\Загрузки\График ТО.xlsx"
With WScript.Arguments
    If .Count > 0 Then
        XLS = .Item(0)
    Else
        MsgBox "Файл не указан", 16
        WScript.Quit    'Exit Sub
    End If
End With
 
Const ListIn = "Описание", R1 = "A5"
Dim NameXLS, R, SN, M, MM, i
Dim D: Set D = CreateObject("Scripting.Dictionary")
 
With CreateObject("Excel.Application")
    .Application.ScreenUpdating = False
    .Visible = True
    .Workbooks.Open XLS
    NameXLS = .ActiveWorkbook.Name
    .Sheets(ListIn).Copy
    .Workbooks(NameXLS).Close
    .ActiveSheet.Name = CStr(Replace(Now, ":", "."))
 
    Set R = .Range(R1)
    .Columns(R.Column).NumberFormat = "@"
    SN = CStr(R)
    
    Do While Trim(SN) <> ""
        SN = CStr(R)
        If Not D.Exists(SN) Then
            M = R.Resize(1, 13)
            M(1, 1) = SN
            D.Add CStr(SN), M
        Else
            M = D.Item(SN)
            MM = R.Resize(1, 13)
            For i = 2 To 13
                If MM(1, i) <> "" Then
                    If M(1, i) = "" Then M(1, i) = MM(1, i) Else M(1, i) = M(1, i) & "," & MM(1, i)
                    D.Item(SN) = M
                End If
            Next
        End If
        Set R = R.Offset(1, 0)
        SN = CStr(R)
    Loop
    
    Set R = .Range(R1)
    For Each SN In D.Keys()
        R.Resize(1, 13) = D.Item(SN)
        Set R = R.Offset(1, 0)
    Next
    .Range(R.Address & ":" & Split(.ActiveSheet.UsedRange.Address, ":")(1)).Clear
    .Application.ScreenUpdating = True
End With

(файл прилагаю, уберите только расширение .txt), на рабочем столе делаем на него иконку, и в проводнике мышкой затягиваем на нее обрабатываемый файл. Единственное, в скрипте надо указать имя листа с исходными данными, адрес ячейки с началом данных ( надеюсь они всегда одинаковы, здесь
Const ListIn = "Описание", R1 = "A5".
Результат - новый файл с обработанными данными. В чем плюс: файл с данными может быть .XLSX, а скрипт никак не привязан к файлу, в отличие от макроса.
Можно, конечно, сделать интерфейс выбора файла, но это не так удобно, ИМХО

@Holmarkland · 25.10.2024, 14:04 **[ТС]**

Сообщение от Angry Old Man

Holmarkland, Завидую молча. Но предлагаю иной подход:

делаем VBS-скрипт в удобном месте

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
Option Explicit
 
Dim XLS                     '''''': XLS = "D:\Мой контент\Загрузки\График ТО.xlsx"
With WScript.Arguments
    If .Count > 0 Then
        XLS = .Item(0)
    Else
        MsgBox "Файл не указан", 16
        WScript.Quit    'Exit Sub
    End If
End With
 
Const ListIn = "Описание", R1 = "A5"
Dim NameXLS, R, SN, M, MM, i
Dim D: Set D = CreateObject("Scripting.Dictionary")
 
With CreateObject("Excel.Application")
    .Application.ScreenUpdating = False
    .Visible = True
    .Workbooks.Open XLS
    NameXLS = .ActiveWorkbook.Name
    .Sheets(ListIn).Copy
    .Workbooks(NameXLS).Close
    .ActiveSheet.Name = CStr(Replace(Now, ":", "."))
 
    Set R = .Range(R1)
    .Columns(R.Column).NumberFormat = "@"
    SN = CStr(R)
    
    Do While Trim(SN) <> ""
        SN = CStr(R)
        If Not D.Exists(SN) Then
            M = R.Resize(1, 13)
            M(1, 1) = SN
            D.Add CStr(SN), M
        Else
            M = D.Item(SN)
            MM = R.Resize(1, 13)
            For i = 2 To 13
                If MM(1, i) <> "" Then
                    If M(1, i) = "" Then M(1, i) = MM(1, i) Else M(1, i) = M(1, i) & "," & MM(1, i)
                    D.Item(SN) = M
                End If
            Next
        End If
        Set R = R.Offset(1, 0)
        SN = CStr(R)
    Loop
    
    Set R = .Range(R1)
    For Each SN In D.Keys()
        R.Resize(1, 13) = D.Item(SN)
        Set R = R.Offset(1, 0)
    Next
    .Range(R.Address & ":" & Split(.ActiveSheet.UsedRange.Address, ":")(1)).Clear
    .Application.ScreenUpdating = True
End With

(файл прилагаю, уберите только расширение .txt), на рабочем столе делаем на него иконку, и в проводнике мышкой затягиваем на нее обрабатываемый файл. Единственное, в скрипте надо указать имя листа с исходными данными, адрес ячейки с началом данных ( надеюсь они всегда одинаковы, здесь
Const ListIn = "Описание", R1 = "A5".
Результат - новый файл с обработанными данными. В чем плюс: файл с данными может быть .XLSX, а скрипт никак не привязан к файлу, в отличие от макроса.
Можно, конечно, сделать интерфейс выбора файла, но это не так удобно, ИМХО

Отлично работает, спасибо за обновленную версию )

Добавлено через 1 минуту
Jamaica, Angry Old Man, Спасибо вам большое еще раз. Я не ожидал, что в 2024 можно получить помощь на форуме. Вы помогли больше моих ожиданий. Спасибо )

Новые блоги и статьи Все статьи Все блоги /
Веб-автоматизация с Python и Selenium AI_Generated 25.06.2025 Selenium с Python — это комбинация, которая выдержала проверку временем. Несмотря на появление новых инструментов вроде Playwright или Puppeteer, связка Python-Selenium остаётся золотым стандартом. . .	CQRS и Event Sourcing на C# ArchitectMsa 25.06.2025 За последние несколько лет сложность корпоративных приложений выросла в геометрической прогрессии. Простые монолитные системы уступили место распределенным микросервисам, а нагрузка на корпоративные. . .	Хак домофона или как открыть дверь по номеру yariko 25.06.2025 Забыли дома ключ. Не проблема. Можно открыть дверь домофона, просто позвонив на свой номер квартиры. Идея состоит в следующем. Внутрь трубки абонента встраивается контроллер, который по звонку сам. . .	Как украсить новогоднюю елку с Q# и Qiskit EggHead 24.06.2025 Что может быть необычнее, чем применить законы квантовой механики для украшения новогодней елки? Пока другие развешивают обычные гирлянды, я решил объединить свою страсть к квантовым вычислениям с. . .	Системы нулевого доверия на C# UnmanagedCoder 24.06.2025 Традиционная архитектура безопасности работает по принципу средневекового замка: создаём высокие стены вокруг корпоративной сети, укрепляем ворота межсетевыми экранами и системами обнаружения. . .
Снова не мой путь. Циклическое среднее, я обеими руками за проверку условия, в ракурсе данной задачи - циклическое среднее в топку. Hrethgir 24.06.2025 Привет. Такой вопрос - нужно выводить среднее математическое между двумя направлениями, интервал значений которых может лежать в диапазоне одного оборота по кругу. Проблема заключается в том, что. . .	Деплой Flask приложения py-thonny 23.06.2025 За годы работы с Flask я натыкался на одни и те же грабли достаточно часто, чтобы наконец научится их обходить. И сегодня хочу поделится опытом, который сбережет вам немало нервных клеток. Начнем с. . .	WebAssembly и контейнеры в .NET Aspire для оркестрации распределенных архитектур ArchitectMsa 23.06.2025 Я наблюдаю, как WebAssembly (или просто WASM) постепенно выходит за рамки своего первоначального предназначения — исполнения кода на стороне браузера. Теперь эта технология проникает в серверную. . .	Непрерывная интеграция для пакета Python Mr. Docker 22.06.2025 Было 4 часа утра пятницы, когда я выпустил новую версию нашей внутренней библиотеки для обработки данных. Релиз 0. 5. 2 содержал небольшой фикс для обработки дат в ISO формате, что может пойти не так?. . .	Продвинутый ETL на C# из OLTP БД в хранилище stackOverflow 22.06.2025 Работая в сфере корпоративной аналитики, я постоянно сталкиваюсь с одним и тем же - нужны чистые, структурированные и, главное, свежие данные. Без них современные аналитические системы, машинное. . .

Преобразовать таблицу

Решение

Решение

@АЕ ᴁ© 4077 / 2379 / 492 Регистрация: 13.12.2016 Сообщений: 8,077 Записей в блоге: 5
	24.10.2024, 16:21
	Holmarkland, а возможно, что в один месяц для одного изделия сразу 2 или 3 ТО? 0

@Holmarkland 0 / 0 / 0 Регистрация: 24.10.2024 Сообщений: 4
	24.10.2024, 17:03 [ТС]
	Нет, такое исключено Добавлено через 10 минут Нет, такое исключено 0