Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование строки ниже, если в ячейке есть определённый текст
 
#1
09.06.2025 13:05:29
Всем добрый день!
Есть файл с несколькими листами, на которых присутствует список кодов, и данные для каждого из них.
В некоторых ячейках указывается один код, а в некоторых идёт перечисление кодов через запятую ",".

Подскажите пожалуйста, как с помощью макроса можно перенести значения после запятой на новую строку и скопировать в неё все данные из исходной строки, а так же в исходной строке оставить только первое значение до запятой. Пустые строки должны остаться пустыми.

Без макроса решил это с помощью вкладки "данные -> текст по столбцам -> разделитель запятая", потом собрал все получившиеся значения в 1 столбец и через формулу
Код
=ВПР(СЦЕПИТЬ("*";$A9;"*");'Исх. список 1'!$A$9:$AQ$50;СТОЛБЕЦ(Результат_1!B$8);0)
все собрал на новом листе.
Можно было бы оставить и этот алгоритм, но таких листов в файле может быть от 2 до 30 и обрабатывать каждый из них руками очень долго.

p.s. Пробовал записать свои действия через "Запись макроса", получается очень много мусора и при внесении в него изменений перестает работать =(.
Ку-Ку мой мальчик!..
 
 
 
#2
09.06.2025 13:19:21
А что делать с пустыми, удалять?
Изменено: Msi2102 - 09.06.2025 13:20:11
 
 
 
#3
09.06.2025 14:19:25
Цитата
Msi2102 написал:
А что делать с пустыми, удалять?

Можно удалить, можно оставить как есть.
Главное чтоб в ячейках с кодами был один код, без запятых.

В моем примере через формулу результат получается без пустых строк.
Изменено: S.K. - 09.06.2025 14:21:48
Ку-Ку мой мальчик!..
 
 
 
#4
09.06.2025 14:37:09
S.K., как вариант с power query
pq
Не столь важно что ты делаешь, важно как ты это делаешь! (Джимми Лансфорд)
 
 
 
#5
09.06.2025 14:42:45
Можно таким макросом, цикл по всем листам сами добавите
Код
Sub Макрос1()
    Dim arr, arr_1, arr_rez, n As Long, m As Long, k As Long, lr As Long, lc As Long
    Set sd = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
    arr = Range(Cells(9, 1), Cells(lr, lc))
    arr = Range("A9:AQ" & lr)
    k = 0
    For n = 1 To UBound(arr)
        If arr(n, 1) <> "" Then
            If Not sd.Exists(arr(n, 2) & "|" & arr(n, 3)) Then Set sd(arr(n, 2) & "|" & arr(n, 3)) = CreateObject("Scripting.Dictionary")
                arr_1 = Split(arr(n, 1), ",")
                For m = LBound(arr_1) To UBound(arr_1)
                    sd(arr(n, 2) & "|" & arr(n, 3)).Add arr_1(m), n
                    k = k + 1
                Next
        End If
    Next
    ReDim arr_rez(1 To k, 1 To lc)
    k = 1
    For Each y In sd
        For Each y1 In sd(y)
            arr_rez(k, 1) = y1
            For n = 2 To lc
                arr_rez(k, n) = arr(sd(y)(y1), n)
            Next
            k = k + 1
        Next
    Next
    ActiveSheet.Copy Before:=Sheets(1)
    With Sheets(1)
        .Range(Cells(9, 1), Cells(9, lc)).ClearContents
        .Range(Cells(10, 1), Cells(lr, lc)).Clear
        .Range(Cells(9, 1), Cells(9, lc)).Copy
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
    End With
End Sub
 
 
 
#6
09.06.2025 14:57:19
Sergius

Спасибо!

Msi2102

Спасибо!

Оба варианта подходят для решения задачи, но как по мне, вариант с  макросом удобнее.
Ку-Ку мой мальчик!..
 
 
 
#7
09.06.2025 15:05:47
S.K., Единственное нужно следить, чтобы не было дулей кода, например есть Наименование 1, Производитель 1 и код 333333, а ниже строка такая же строка с тем же наименованием, производителем и кодом. Просто не знал, что с этим делать, то-ли их складывать, то-ли добавлять индекс типа 333333_1, пока просто выдаст ошибку
Изменено: Msi2102 - 09.06.2025 15:07:26
 
 
 
#8
09.06.2025 15:31:53
Msi2102, спасибо за комментарий, очень важное уточнение.
По идее таких случаев быть не должно. А если появится дубль, то уже будем проверять руками причину его возникновения и что с ним делать
Ку-Ку мой мальчик!..
 
 
 
#9
09.06.2025 15:48:34
Немного изменил макрос, теперь если будет появляться дубль (наименование, производитель и код), то номера строк по Excel и повторяющиеся коды, будут отображаться на листе "Дубли"
Код
Sub Макрос1()
    Dim arr, arr_1, arr_rez, arr_osh, n As Long, m As Long, k As Long, lr As Long, lc As Long
    Set sd = CreateObject("Scripting.Dictionary")
    Set sd_osh = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
    arr = Range(Cells(9, 1), Cells(lr, lc))
    arr = Range("A9:AQ" & lr)
    k = 0
    j = 0
    For n = 1 To UBound(arr)
        If arr(n, 1) <> "" Then
            If Not sd.Exists(arr(n, 2) & "|" & arr(n, 3)) Then Set sd(arr(n, 2) & "|" & arr(n, 3)) = CreateObject("Scripting.Dictionary")
            arr_1 = Split(arr(n, 1), ",")
            For m = LBound(arr_1) To UBound(arr_1)
                If Not sd(arr(n, 2) & "|" & arr(n, 3)).Exists(arr_1(m)) Then
                    sd(arr(n, 2) & "|" & arr(n, 3)).Add arr_1(m), n
                    k = k + 1
                Else
                    If Not sd_osh.Exists("Строка " & n + 8) Then
                        sd_osh.Add "Строка " & n + 8, arr_1(m)
                        j = j + 1
                    Else
                        sd_osh("Строка " & n + 8) = sd_osh("Строка " & n + 8) & "; " & arr_1(m)
                    End If
                End If
            Next
        End If
    Next
    ReDim arr_rez(1 To k, 1 To lc)
    k = 1
    For Each y In sd
        For Each y1 In sd(y)
            arr_rez(k, 1) = y1
            For n = 2 To lc
                arr_rez(k, n) = arr(sd(y)(y1), n)
            Next
            k = k + 1
        Next
    Next
    ReDim arr_osh(1 To j, 1 To 2)
    k = 1
    For Each y In sd_osh
        arr_osh(k, 1) = y
        arr_osh(k, 2) = sd_osh(y)
        k = k + 1
    Next
    ActiveSheet.Copy Before:=Sheets(1)
    With Sheets(1)
        .Range(Cells(9, 1), Cells(9, lc)).ClearContents
        .Range(Cells(10, 1), Cells(lr, lc)).Clear
        .Range(Cells(9, 1), Cells(9, lc)).Copy
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
    End With
    With Sheets("Дубли")
        .Cells.Clear
        .Range("A1").Resize(UBound(arr_osh), UBound(arr_osh, 2)) = arr_osh
    End With
End Sub
Изменено: Msi2102 - 09.06.2025 15:50:12
 
 
 
#10
09.06.2025 15:56:14
Msi2102,  шикарно!.


Цитата
то номера строк по Excel и повторяющиеся коды, будут отображаться на листе "Дубли"

А название листа, на котором возникли дубли, тоже будет отображаться?
Ку-Ку мой мальчик!..
 
 
 
#11
09.06.2025 17:02:32
Вот с названием листа, только при каждом запуске макроса лист Дубли очищается
ps ещё изменил макрос, наверно так будет правильнее (Макрос 2)
Код
Sub Макрос2()
    Dim arr, arr_1, arr_rez, arr_osh, n As Long, m As Long, k As Long, lr As Long, lc As Long, nm As String
    Set sd = CreateObject("Scripting.Dictionary")
    Set sd_osh = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
    nm = ActiveSheet.Name
    arr = Range(Cells(9, 1), Cells(lr, lc))
    arr = Range("A9:AQ" & lr)
    k = 0
    j = 0
    For n = 1 To UBound(arr)
        If arr(n, 1) <> "" Then
            arr_1 = Split(arr(n, 1), ",")
            For m = LBound(arr_1) To UBound(arr_1)
                If Not sd.Exists(arr_1(m) & "|" & arr(n, 2) & "|" & arr(n, 3)) Then
                    sd.Add arr_1(m) & "|" & arr(n, 2) & "|" & arr(n, 3), n
                    k = k + 1
                Else
                    If Not sd_osh.Exists("Строка " & n + 8) Then
                        sd_osh.Add "Строка " & n + 8, arr_1(m)
                        j = j + 1
                    Else
                        sd_osh("Строка " & n + 8) = sd_osh("Строка " & n + 8) & "; " & arr_1(m)
                    End If
                End If
            Next
        End If
    Next
    
    ReDim arr_rez(1 To k, 1 To lc)
    k = 1
    For Each y In sd
        arr_rez(k, 1) = Split(y, "|")(0)
        For n = 2 To lc
            arr_rez(k, n) = arr(sd(y), n)
        Next
        k = k + 1
    Next
    ActiveSheet.Copy Before:=Sheets(1)
    With Sheets(1)
        .Range(Cells(9, 1), Cells(9, lc)).ClearContents
        .Range(Cells(10, 1), Cells(lr, lc)).Clear
        .Range(Cells(9, 1), Cells(9, lc)).Copy
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("A9").Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
    End With
    
    Sheets("Дубли").Cells.Clear
    If j > 0 Then
        ReDim arr_osh(1 To j, 1 To 3)
        k = 1
        For Each y In sd_osh
            arr_osh(k, 1) = nm
            arr_osh(k, 2) = y
            arr_osh(k, 3) = sd_osh(y)
            k = k + 1
        Next
        Sheets("Дубли").Range("A1").Resize(UBound(arr_osh), UBound(arr_osh, 2)) = arr_osh
    End If
End Sub
 
 
 
#12
09.06.2025 17:10:34
Msi2102,  в очередной раз огромное спасибо!
Ку-Ку мой мальчик!..
 
 
 
Страницы: 1
Читают тему
Наверх