Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Формирование списка разделяя текст в ячейке по строкам
 
#1
15.06.2022 16:08:05
Добрый день!
Подскажите как можно реализовать на языке VBA, формирование списка?
В столбце "инструкция", на листе "данные" имеем перечень инструкций, они разделены ; (точкой с запятой), нужно на лист "Список инструкций" в колонку инструкция внести все инструкции без дубликатов.

Пример:
если в ячейке: ОТИ-1244; ОТИ-451; ОТИ-510, ОТИ-80
то сделать как:
ОТИ-1244
ОТИ-451
ОТИ-510
ОТИ-80

После сформированного списка на листе "Список инструкций" в колонку "Операция" занести все операции через ; (точкой с запятой) в которых используется эта инструкция.

Пример:
Имеем инструкцию ОТИ-080 она используется в операциях 005; 010
 
 
 
#2
15.06.2022 17:14:25
Денис Ш., добрый вечер!
код:
Макрос - "Интрукция_Операция" (запускать по Alt + F8)
Код
Sub Интрукция_Операция()
Dim arr, Dict As Object
Dim i, j, t, tmp, temp, lr As Long

arr = Worksheets("Данные").Cells(1, 1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 7), ";") Then
        tmp = Split(arr(i, 7), ";")
        For Each j In tmp
            j = Trim(j)
            If InStr(j, ",") Then
                temp = Split(j, ",")
                For Each t In temp
                    t = Trim(t)
                    If Not Dict.exists(t) Then
                        Dict.Add t, arr(i, 3)
                    Else
                        If InStr(Dict(t), arr(i, 3)) = 0 Then
                            Dict(t) = Dict(t) & ";" & arr(i, 3)
                        End If
                    End If
                Next t
            
            Else
                If Not Dict.exists(j) Then
                    Dict.Add j, arr(i, 3)
                Else
                    If InStr(Dict(j), arr(i, 3)) = 0 Then
                        Dict(j) = Dict(j) & ";" & arr(i, 3)
                    End If
                End If
            End If
        Next j
    Else
        If Not Dict.exists(arr(i, 7)) Then
            Dict.Add arr(i, 7), arr(i, 3)
        Else
            If InStr(Dict(arr(i, 7)), arr(i, 3)) = 0 Then
                Dict(arr(i, 7)) = Dict(arr(i, 7)) & ";" & arr(i, 3)
            End If
        End If
    End If
Next i
With Worksheets("Список инструкций")
    .Range(.Cells(2, 1).End(xlDown), .Cells(2, 1).End(xlToRight)).ClearContents
For Each j In Dict.keys
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(lr + 1, 1) = j
    .Cells(lr + 1, 2) = Dict(j)
Next j
End With
End Sub
 
 
 
#3
15.06.2022 17:14:54
А ОТИ-80 и ОТИ-080 это одно и тоже?
Цитата
они разделены ; (точкой с запятой)
Не только, есть и запятой
Можно ещё PQ
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Тип = Table.TransformColumnTypes(Источник,{{"Номер операции", type text}}),
    Замена = Table.ReplaceValue(Тип,",",";",Replacer.ReplaceText,{"Инструкция"}),
    Разделить = Table.ExpandListColumn(Table.TransformColumns(Замена, {{"Инструкция", Splitter.SplitTextByDelimiter("; ", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Инструкция"),
    Группа = Table.Group(Разделить, {"Инструкция"}, {{"Количество", each _, type table [Детали=text, Оборудование=text, Цех=any, Участок=any, Номер операции=text, Название операции=text, Инструкция=nullable text]}}),
    Операция = Table.AddColumn(Группа, "Операция", each Table.Column([Количество],"Номер операции")),
    Извлечь = Table.TransformColumns(Операция, {"Операция", each Text.Combine(List.Transform(List.Distinct(_), Text.From), "; "), type text})
in
    Извлечь
Изменено: Msi2102 - 15.06.2022 17:34:59
 
 
 
#4
15.06.2022 18:18:28
Так тоже макросом, но немного покороче
Код
Sub Операции()
Dim arr As Variant, arr1 As Variant, arr2 As Variant
Set dic = CreateObject("Scripting.Dictionary")
arr1 = Sheets("Данные").Range("A2:G" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(arr1)
    arr = Split(arr1(i, 7), "; ")
    For n = LBound(arr) To UBound(arr)
        If Not dic.exists(arr(n)) Then Set dic(arr(n)) = CreateObject("Scripting.Dictionary")
        If Not dic(arr(n)).exists(CStr(arr1(i, 5))) Then dic(arr(n)).Add CStr(arr1(i, 5)), CStr(arr1(i, 5))
    Next
Next
ReDim arr2(1 To dic.Count, 1 To 2)
n = 0
For Each y In dic
    n = n + 1
    arr2(n, 1) = y
    arr2(n, 2) = Join(dic(y).Keys, "; ")
Next
Worksheets("Список инструкций").Cells(2, 1).Resize(UBound(arr2), 2) = arr2
End Sub
 
 
 
#5
15.06.2022 18:27:00
Msi2102, Запятая это ошибка в заполнении. ОТИ-80 и ОТИ-080 это разное
 
 
 
#6
15.06.2022 18:29:01
Msi2102, Спасибо, то что нужно, разобраться бы в этом теперь. Я пытался пойти в этом направлении
Код
Sub Список_инструкций()

Dim i&, x
Dim aaa As Variant
Dim zzz As Variant
Dim diapazon As Variant

diapazon = Range("G2:G5")

For Each zzz In diapazon
    For Each x In Split(zzz, "; ")
        If x <> "" Then i = i + 1: Cells(i, 12) = x
    Next x
Next zzz

Columns(12).RemoveDuplicates 1

End Sub
 
 
 
#7
15.06.2022 19:18:29
Денис Ш., мой макрос не подошел?
 
 
 
#8
15.06.2022 19:48:03
artemkau88, привыкай! :) ТС-ы несмотря на правила форума и обругать могут помогающих :) Типа хочу две строчки, а тут двадцать :)  Если хочешь помочь, не жди благодарности, а просто помоги :)
 
 
 
#9
15.06.2022 19:50:27
_Igor_61, понял.  :)
Цитата
написал:
просто помоги
вот и хотел узнать, помог или нет  :D .
А в ответ тишина..... :D  
 
 
 
#10
15.06.2022 20:51:56
artemkau88, Прошу простить меня, я последний что увидел попробовал и удалился от компа.
Ваш тоже делает то что надо, только поправил чуть-чуть, выводил не номер операции а номер цеха
Код
Sub Интрукция_Операция()
Dim arr, Dict As Object
Dim i, j, t, tmp, temp, lr As Long

arr = Worksheets("Данные").Cells(1, 1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 7), ";") Then
        tmp = Split(arr(i, 7), ";")
        For Each j In tmp
            j = Trim(j)
            If InStr(j, ",") Then
                temp = Split(j, ",")
                For Each t In temp
                    t = Trim(t)
                    If Not Dict.exists(t) Then
                        Dict.Add t, arr(i, 5)
                    Else
                        If InStr(Dict(t), arr(i, 5)) = 0 Then
                            Dict(t) = Dict(t) & ";" & arr(i, 5)
                        End If
                    End If
                Next t
            
            Else
                If Not Dict.exists(j) Then
                    Dict.Add j, arr(i, 5)
                Else
                    If InStr(Dict(j), arr(i, 5)) = 0 Then
                        Dict(j) = Dict(j) & ";" & arr(i, 5)
                    End If
                End If
            End If
        Next j
    Else
        If Not Dict.exists(arr(i, 7)) Then
            Dict.Add arr(i, 7), arr(i, 5)
        Else
            If InStr(Dict(arr(i, 7)), arr(i, 5)) = 0 Then
                Dict(arr(i, 7)) = Dict(arr(i, 7)) & ";" & arr(i, 5)
            End If
        End If
    End If
Next i
With Worksheets("Список инструкций")
    .Range(.Cells(2, 1).End(xlDown), .Cells(2, 1).End(xlToRight)).ClearContents
For Each j In Dict.keys
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(lr + 1, 1) = j
    .Cells(lr + 1, 2) = Dict(j)
Next j
End With
End Sub
 
 
 
#11
15.06.2022 20:54:24
Денис Ш., понял Вас!
Спасибо за обратную связь  :)  
 
 
 
#12
15.06.2022 22:52:26
artemkau88, как говорят "аппетит приходит во время еды"
Можно тоже самое реализовать но заполнять таблицу на листе ПИ1:
Обозначение - список ОТИ
Номера операций - номера операций
Если строк не хватает, то перейти на лист ПИ2, если и с ним не хватает то добавить копию листа ПИ2
 
 
 
#13
16.06.2022 09:12:07
Денис Ш., поправил код, тестируйте  :) :
Код
Sub Интрукция_Операция()
Dim arr, Dict As Object
Dim i, j, t, tmp, temp, lr As Long, LastRow As Long, rngTarget As Range
 
arr = Worksheets("Данные").Cells(1, 1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 7), ";") Then
        tmp = Split(arr(i, 7), ";")
        For Each j In tmp
            j = Trim(j)
            If InStr(j, ",") Then
                temp = Split(j, ",")
                For Each t In temp
                    t = Trim(t)
                    If Not Dict.exists(t) Then
                        Dict.Add t, arr(i, 5)
                    Else
                        If InStr(Dict(t), arr(i, 5)) = 0 Then
                            Dict(t) = Dict(t) & ";" & arr(i, 5)
                        End If
                    End If
                Next t
             
            Else
                If Not Dict.exists(j) Then
                    Dict.Add j, arr(i, 5)
                Else
                    If InStr(Dict(j), arr(i, 5)) = 0 Then
                        Dict(j) = Dict(j) & ";" & arr(i, 5)
                    End If
                End If
            End If
        Next j
    Else
        If Not Dict.exists(arr(i, 7)) Then
            Dict.Add arr(i, 7), arr(i, 5)
        Else
            If InStr(Dict(arr(i, 7)), arr(i, 5)) = 0 Then
                Dict(arr(i, 7)) = Dict(arr(i, 7)) & ";" & arr(i, 5)
            End If
        End If
    End If
Next i
With Worksheets("ПИ1")
    LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1
    Set rngTarget = .Range("A19")
For Each j In Dict.keys
    If rngTarget.MergeArea.Row <> LastRow Then
    
        rngTarget.MergeArea = j
        rngTarget.MergeArea.Offset(0, 1) = Dict(j)
        Set rngTarget = rngTarget.MergeArea.Offset(1, 0)
    Else
        With Worksheets("ПИ2")
            LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row - 5
            Set rngTarget = .Range("A18")
        End With
    End If
Next j
End With
End Sub
Изменено: artemkau88 - 16.06.2022 09:52:14
 
 
 
#14
17.06.2022 10:36:12
artemkau88, Спасибо, все круто, но когда избыток инструкций он перезаписывает их на листе ПИ2
 
 
 
#15
17.06.2022 11:24:09
Цитата
Денис Ш. написал:
но когда избыток инструкций он перезаписывает их на листе ПИ
можете уточнить что делать в этом случае?
 
 
 
#16
18.06.2022 12:29:39
artemkau88, Например, если не хватает двух листов для заполнения, то скопировать ПИ2 но под именем ПИ3 и заполнять оставшиеся в него
 
 
 
#17
18.06.2022 13:19:14
Денис Ш., понял Вас.
код:
Код
Sub Интрукция_Операция()
Dim arr, Dict As Object, sh_var As Worksheet, lrRange As Range, shCnt As Long
Dim i, j, t, tmp, temp, lr As Long, LastRow As Long, rngTarget As Range, rngOperation As Range
Application.DisplayAlerts = False
arr = Worksheets("Данные").Cells(1, 1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 7), ";") Then
        tmp = Split(arr(i, 7), ";")
        For Each j In tmp
            j = Trim(j)
            If InStr(j, ",") Then
                temp = Split(j, ",")
                For Each t In temp
                    t = Trim(t)
                    If Not Dict.exists(t) Then
                        Dict.Add t, arr(i, 5)
                    Else
                        If InStr(Dict(t), arr(i, 5)) = 0 Then
                            Dict(t) = Dict(t) & ";" & arr(i, 5)
                        End If
                    End If
                Next t
              
            Else
                If Not Dict.exists(j) Then
                    Dict.Add j, arr(i, 5)
                Else
                    If InStr(Dict(j), arr(i, 5)) = 0 Then
                        Dict(j) = Dict(j) & ";" & arr(i, 5)
                    End If
                End If
            End If
        Next j
    Else
        If Not Dict.exists(arr(i, 7)) Then
            Dict.Add arr(i, 7), arr(i, 5)
        Else
            If InStr(Dict(arr(i, 7)), arr(i, 5)) = 0 Then
                Dict(arr(i, 7)) = Dict(arr(i, 7)) & ";" & arr(i, 5)
            End If
        End If
    End If
Next i
Set sh_var = Worksheets("ПИ1")
Set lrRange = sh_var.Cells.Find("ОК"): If lrRange Is Nothing Then Set lrRange = sh_var.Cells.Find("МК"): LastRow = lrRange.Row - 1
Set rngTarget = sh_var.Cells.Find("Обозначение")
Set rngOperation = rngTarget.End(xlToRight).End(xlToRight).Offset(1, 0): Set rngTarget = rngTarget.MergeArea.Offset(1, 0)

        For Each j In Dict.keys
            If rngTarget.MergeArea.Row <> LastRow Then
                rngTarget.MergeArea = j
                rngOperation = Dict(j)
                Set rngTarget = rngTarget.MergeArea.Offset(1, 0): Set rngOperation = rngOperation.Offset(1, 0)
            Else
                shCnt = Int(Right(sh_var.Name, 1))
                If sh_var.Index = Sheets.Count Then
                    sh_var.Copy after:=Worksheets(Worksheets.Count)
                    Set sh_var = Worksheets(Worksheets.Count): sh_var.Name = "ПИ" & shCnt + 1
                Else
                    Set sh_var = Worksheets("ПИ" & shCnt + 1)
                End If
                    With sh_var
                        Set lrRange = .Cells.Find("ОК"): If lrRange Is Nothing Then Set lrRange = .Cells.Find("МК")
                        LastRow = lrRange.Row - 1
                        Set rngTarget = sh_var.Cells.Find("Обозначение"): Set rngOperation = rngTarget.End(xlToRight).End(xlToRight).Offset(1, 0): Set rngTarget = rngTarget.Offset(1, 0)
                        .Range(.Cells(rngTarget.Row, 1), .Cells(LastRow, .Cells.Find("Номера операций").Column)).Value = ""
                    End With
                rngTarget.MergeArea = j
                rngOperation = Dict(j)
                Set rngTarget = rngTarget.MergeArea.Offset(1, 0): Set rngOperation = rngOperation.Offset(1, 0)
            End If
        Next j
Application.DisplayAlerts = True
End Sub

Тестируйте :)  
Изменено: artemkau88 - 20.06.2022 14:14:41
 
 
 
#18
20.06.2022 09:44:13
artemkau88, Добрый день. Немного не то. Листы ПИ1 и ПИ2 немного отличаются форматом, т.е. ПИ1 всегда должен быть первым, а вот ПИ2 уже множить по содержимому., вот как файл
Цитата
artemkau88, как говорят "аппетит приходит во время еды"
Можно тоже самое реализовать но заполнять таблицу на листе ПИ1:
Обозначение - список ОТИ
Номера операций - номера операций
Если строк не хватает, то перейти на лист ПИ2, если и с ним не хватает то добавить копию листа ПИ2
Прикрепленные файлы
И еще можно перенести номера операций в колонку крайнюю правую, сейчас вносятся в колонку с наименованием
 
 
 
#19
20.06.2022 14:15:11
Денис Ш., подправил код в сообщении выше и обновил файл. Тестируйте
 
 
 
#20
20.06.2022 16:55:16
artemkau88, Все круто, спасибо большое!
 
 
 
#21
29.07.2022 16:33:43
Msi2102, Поменялась немного структура документа. С листа "Список инструкций"? Чтобы кнопка была не на листе Данные... Пытался сделать, но почему-то если запустить с другого листа данные выдает совершено другие
Изменено: Денис Ш. - 29.07.2022 16:34:46
 
 
 
#22
29.07.2022 17:25:41
Вроде бы получилось. Я указал на каком листе искать последнюю заполненную строчку:
Код
Sub aaaaaaaaaaaaaaa()
Dim arr As Variant, arr1 As Variant, arr2 As Variant, dic As Variant, i As Variant, n As Variant, y As Variant

Set dic = CreateObject("Scripting.Dictionary")
arr1 = Sheets("Рабочая база деталей").Range("A9:H" & Sheets("Рабочая база деталей").Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(arr1)
    arr = Split(arr1(i, 8), "; ")
    For n = LBound(arr) To UBound(arr)
        If Not dic.exists(arr(n)) Then Set dic(arr(n)) = CreateObject("Scripting.Dictionary")
        If Not dic(arr(n)).exists(CStr(arr1(i, 5))) Then dic(arr(n)).Add CStr(arr1(i, 5)), CStr(arr1(i, 5))
    Next
Next
ReDim arr2(1 To dic.Count, 1 To 2)
n = 0
For Each y In dic
    n = n + 1
    arr2(n, 1) = y
    arr2(n, 2) = Join(dic(y).keys, "; ")
Next
Worksheets("Список инструкций").Cells(2, 1).Resize(UBound(arr2), 2) = arr2
End Sub
 
 
 
#23
29.07.2022 23:23:41
Денис Ш.,
1. вот эту строку
Код
arr1 = Sheets("Рабочая база деталей").Range("A9:H" & Sheets("Рабочая база деталей").Cells(Rows.Count, 1).End(xlUp).Row).Value

правильнее записать вот так

Код
    With Sheets("Рабочая база деталей")
        arr1 = .Range("A9:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With

тут очень важны точки перед .Range, .Cells и .Rows

2. Так как у вас есть начальные нули (025), то при выгрузке результата на второй лист одинарной (единичной) Операции на лист ведущий 0 будет удалён и 025 превратиться в 25.
Чтобы этого избежать нужно вот эту строку
Код
Worksheets("Список инструкций").Cells(2, 1).Resize(UBound(arr2), 2) = arr2

заменить на

Код
    With Worksheets("Список инструкций")
        .Columns(2).NumberFormat = "@"
        .Cells(2, 1).Resize(UBound(arr2), 2).Value = arr2
    End With
Изменено: New - 29.07.2022 23:50:53
 
 
 
Страницы: 1
Наверх