Добрый день. Возможно, кто-то знает как решить следующую задачу. Есть артикулы с предполагаемым цветом (Лист 1) и артикулы с цветом, который изменить нельзя (Лист 2). Необходимо сделать так, чтобы значения, которые находятся на Лист 1 в поле цвет, были уникальными и не совпадали со значениями в поле цвет на Лист 2 в пределах одного Группировочного кода. Чтобы сделать значение уникальным, необходимо к значению прибавить 1, т.е. должно получится: черный 1, черный 2, черный 3. Стоит обратить внимание, что значения на Лист 1 могут в рамках одного Группировочного кода иметь 2 и более артикулов с одинаковым значением в поле цвет. каждое значение должно быть уникальным. Также стоит обратить внимание, что значения на лист 2 могут также иметь такие значения: черный 1, черный 2, черный 3 и т.д.. Необходимо сделать так, чтобы значению с первого листа прибавилась единица, если не нашлось свободного значения.
Добрый день. Возможно, кто-то знает как решить следующую задачу. Есть артикулы с предполагаемым цветом (Лист 1) и артикулы с цветом, который изменить нельзя (Лист 2). Необходимо сделать так, чтобы значения, которые находятся на Лист 1 в поле цвет, были уникальными и не совпадали со значениями в поле цвет на Лист 2 в пределах одного Группировочного кода. Чтобы сделать значение уникальным, необходимо к значению прибавить 1, т.е. должно получится: черный 1, черный 2, черный 3. Стоит обратить внимание, что значения на Лист 1 могут в рамках одного Группировочного кода иметь 2 и более артикулов с одинаковым значением в поле цвет. каждое значение должно быть уникальным. Также стоит обратить внимание, что значения на лист 2 могут также иметь такие значения: черный 1, черный 2, черный 3 и т.д.. Необходимо сделать так, чтобы значению с первого листа прибавилась единица, если не нашлось свободного значения.elycioo
Попробуйте таким макросом, если правильно понял [vba]
Код
Sub Макрос1() Dim arr1, arr2, x, y, k, n As Long, m As Long Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") Set re = CreateObject("VBScript.RegExp") re.Pattern = "\d+$" arr1 = Sheets("Лист 1").Range("A2:C" & Sheets("Лист 1").Cells(Rows.Count, 1).End(xlUp).Row).Value arr2 = Sheets("Лист 2").Range("A2:C" & Sheets("Лист 2").Cells(Rows.Count, 1).End(xlUp).Row).Value For n = 1 To UBound(arr1) arr1(n, 3) = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(arr1(n, 3)) Then Set dic1(arr1(n, 1))(arr1(n, 3)) = CreateObject("Scripting.dictionary") dic1(arr1(n, 1))(arr1(n, 3)).Add dic1(arr1(n, 1))(arr1(n, 3)).Count + 1, arr1(n, 2) Next For n = 1 To UBound(arr2) arr2(n, 3) = LCase(RTrim(re.Replace(Trim(arr2(n, 3)), ""))) If Not dic2.exists(arr2(n, 1)) Then Set dic2(arr2(n, 1)) = CreateObject("Scripting.dictionary") If Not dic2(arr2(n, 1)).exists(arr2(n, 3)) Then Set dic2(arr2(n, 1))(arr2(n, 3)) = CreateObject("Scripting.dictionary") m = 0 If dic1.exists(arr2(n, 1)) Then If dic1(arr2(n, 1)).exists(arr2(n, 3)) Then m = dic1(arr2(n, 1))(arr2(n, 3)).Count dic2(arr2(n, 1))(arr2(n, 3)).Add m + dic2(arr2(n, 1))(arr2(n, 3)).Count + 1, arr2(n, 2) Next n = 1 For Each y In dic1 For Each x In dic1(y) For Each k In dic1(y)(x) arr1(n, 1) = y arr1(n, 2) = dic1(y)(x).Item(k) arr1(n, 3) = x & " " & k n = n + 1 Next Next Next n = 1 For Each y In dic2 For Each x In dic2(y) For Each k In dic2(y)(x) arr2(n, 1) = y arr2(n, 2) = dic2(y)(x).Item(k) arr2(n, 3) = x & " " & k n = n + 1 Next Next Next Sheets("Лист 1").Range("A2").Resize(UBound(arr1), 3) = arr1 Sheets("Лист 2").Range("A2").Resize(UBound(arr2), 3) = arr2 End Sub
[/vba] Если стоит стоит старая нумерация, то она удаляется и нумеруется заново Была ошибка, исправил, файл перезалил
Попробуйте таким макросом, если правильно понял [vba]
Код
Sub Макрос1() Dim arr1, arr2, x, y, k, n As Long, m As Long Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") Set re = CreateObject("VBScript.RegExp") re.Pattern = "\d+$" arr1 = Sheets("Лист 1").Range("A2:C" & Sheets("Лист 1").Cells(Rows.Count, 1).End(xlUp).Row).Value arr2 = Sheets("Лист 2").Range("A2:C" & Sheets("Лист 2").Cells(Rows.Count, 1).End(xlUp).Row).Value For n = 1 To UBound(arr1) arr1(n, 3) = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(arr1(n, 3)) Then Set dic1(arr1(n, 1))(arr1(n, 3)) = CreateObject("Scripting.dictionary") dic1(arr1(n, 1))(arr1(n, 3)).Add dic1(arr1(n, 1))(arr1(n, 3)).Count + 1, arr1(n, 2) Next For n = 1 To UBound(arr2) arr2(n, 3) = LCase(RTrim(re.Replace(Trim(arr2(n, 3)), ""))) If Not dic2.exists(arr2(n, 1)) Then Set dic2(arr2(n, 1)) = CreateObject("Scripting.dictionary") If Not dic2(arr2(n, 1)).exists(arr2(n, 3)) Then Set dic2(arr2(n, 1))(arr2(n, 3)) = CreateObject("Scripting.dictionary") m = 0 If dic1.exists(arr2(n, 1)) Then If dic1(arr2(n, 1)).exists(arr2(n, 3)) Then m = dic1(arr2(n, 1))(arr2(n, 3)).Count dic2(arr2(n, 1))(arr2(n, 3)).Add m + dic2(arr2(n, 1))(arr2(n, 3)).Count + 1, arr2(n, 2) Next n = 1 For Each y In dic1 For Each x In dic1(y) For Each k In dic1(y)(x) arr1(n, 1) = y arr1(n, 2) = dic1(y)(x).Item(k) arr1(n, 3) = x & " " & k n = n + 1 Next Next Next n = 1 For Each y In dic2 For Each x In dic2(y) For Each k In dic2(y)(x) arr2(n, 1) = y arr2(n, 2) = dic2(y)(x).Item(k) arr2(n, 3) = x & " " & k n = n + 1 Next Next Next Sheets("Лист 1").Range("A2").Resize(UBound(arr1), 3) = arr1 Sheets("Лист 2").Range("A2").Resize(UBound(arr2), 3) = arr2 End Sub
[/vba] Если стоит стоит старая нумерация, то она удаляется и нумеруется заново Была ошибка, исправил, файл перезалилmsi2102
msi2102, Тут еще ошибка в том, что данный макрос меняет значения на листе 2, а должен не менять их, а учитывать при присваивании значений для цвета на листе 1.
msi2102, Тут еще ошибка в том, что данный макрос меняет значения на листе 2, а должен не менять их, а учитывать при присваивании значений для цвета на листе 1.elycioo
Немного об алгоритме: - Вначале собираем пронумерованные цвета с листа 2, дубли нумеруются прибавляя 1 к существующему номеру; - Собираем оставшиеся цвета без нумерации и нумеруем их начиная с 1 или если 1 есть то со следующего номера; - На листе 1 удаляется вся предыдущая нумерация и присваивается нумерация с 1 или со следующего учитывая оба списка. Немного пояснений: Если номер на листе 2 повторяется дважды (это наглядно на примере: Группировочный код - A056218825, цвет Синий 2) то к дублям прибавляется следующий номер (на выше указанном примере результат: Синий 2, Синий 3 и т.д.) вне зависимости от наличия предыдущих номеров, поэтому может сложиться ситуация, если больше не будет строки с таким группировочным кодом и цветом (например группировочный код a11111111111111, цвет Синий 2) то начало будет не с 1, а с 2. Если есть ещё дублирующие строки с одинаковым кодом и цветом, но без номера, то нумерация этих значений начинается с 1, поэтому возможен разрыв нумерации (например группировочный код а22222222222222, два цвета Синий с номером 7 и один без номера и один на листе 2). [vba]
Код
Sub Макрос2() Dim arr1, arr2, x, y, k, n As Long, nn As Long, m As Long Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") Set re = CreateObject("VBScript.RegExp") re.Pattern = "\d+$" arr2 = Sheets("Лист 1").Range("A2:C" & Sheets("Лист 1").Cells(Rows.Count, 1).End(xlUp).Row).Value arr1 = Sheets("Лист 2").Range("A2:C" & Sheets("Лист 2").Cells(Rows.Count, 1).End(xlUp).Row).Value For n = 1 To UBound(arr1) col = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If re.Test(arr1(n, 3)) Then m = CLng(re.Execute(arr1(n, 3)).Item(0)) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(col) Then Set dic1(arr1(n, 1))(col) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1))(col).exists(m) Then dic1(arr1(n, 1))(col).Add m, arr1(n, 2) Else Do While dic1(arr1(n, 1))(col).exists(m) m = m + 1 Loop dic1(arr1(n, 1))(col).Add m, arr1(n, 2) End If arr1(n, 1) = "" End If Next For n = 1 To UBound(arr1) If arr1(n, 1) <> "" Then arr1(n, 3) = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(arr1(n, 3)) Then Set dic1(arr1(n, 1))(arr1(n, 3)) = CreateObject("Scripting.dictionary") For m = 1 To dic1(arr1(n, 1))(arr1(n, 3)).Count + 1 If Not dic1(arr1(n, 1))(arr1(n, 3)).exists(m) Then dic1(arr1(n, 1))(arr1(n, 3)).Add m, arr1(n, 2): Exit For Next End If Next For n = 1 To UBound(arr2) arr2(n, 3) = LCase(RTrim(re.Replace(Trim(arr2(n, 3)), ""))) If Not dic2.exists(arr2(n, 1)) Then Set dic2(arr2(n, 1)) = CreateObject("Scripting.dictionary") If Not dic2(arr2(n, 1)).exists(arr2(n, 3)) Then Set dic2(arr2(n, 1))(arr2(n, 3)) = CreateObject("Scripting.dictionary") nn = 0 If dic1.exists(arr2(n, 1)) Then If dic1(arr2(n, 1)).exists(arr2(n, 3)) Then nn = dic1(arr2(n, 1))(arr2(n, 3)).Count For m = 1 To nn + 1 + dic2(arr2(n, 1))(arr2(n, 3)).Count + 1 If nn = 0 Then If Not dic2(arr2(n, 1))(arr2(n, 3)).exists(m) Then dic2(arr2(n, 1))(arr2(n, 3)).Add m, arr2(n, 2): Exit For Else If Not dic2(arr2(n, 1))(arr2(n, 3)).exists(m) And Not dic1(arr2(n, 1))(arr2(n, 3)).exists(m) Then dic2(arr2(n, 1))(arr2(n, 3)).Add m, arr2(n, 2): Exit For End If Next Next n = 1 For Each y In dic1 For Each x In dic1(y) For Each k In dic1(y)(x) arr1(n, 1) = y arr1(n, 2) = dic1(y)(x).Item(k) arr1(n, 3) = x & " " & k n = n + 1 Next Next Next n = 1 For Each y In dic2 For Each x In dic2(y) For Each k In dic2(y)(x) arr2(n, 1) = y arr2(n, 2) = dic2(y)(x).Item(k) arr2(n, 3) = x & " " & k n = n + 1 Next Next Next dic1.RemoveAll dic2.RemoveAll Sheets("Лист 1").Range("E2").Resize(UBound(arr2), 3) = arr2 Sheets("Лист 2").Range("E2").Resize(UBound(arr1), 3) = arr1 End Sub
[/vba] Для лучшего понимания таблицу с результатом вставил рядом
Немного об алгоритме: - Вначале собираем пронумерованные цвета с листа 2, дубли нумеруются прибавляя 1 к существующему номеру; - Собираем оставшиеся цвета без нумерации и нумеруем их начиная с 1 или если 1 есть то со следующего номера; - На листе 1 удаляется вся предыдущая нумерация и присваивается нумерация с 1 или со следующего учитывая оба списка. Немного пояснений: Если номер на листе 2 повторяется дважды (это наглядно на примере: Группировочный код - A056218825, цвет Синий 2) то к дублям прибавляется следующий номер (на выше указанном примере результат: Синий 2, Синий 3 и т.д.) вне зависимости от наличия предыдущих номеров, поэтому может сложиться ситуация, если больше не будет строки с таким группировочным кодом и цветом (например группировочный код a11111111111111, цвет Синий 2) то начало будет не с 1, а с 2. Если есть ещё дублирующие строки с одинаковым кодом и цветом, но без номера, то нумерация этих значений начинается с 1, поэтому возможен разрыв нумерации (например группировочный код а22222222222222, два цвета Синий с номером 7 и один без номера и один на листе 2). [vba]
Код
Sub Макрос2() Dim arr1, arr2, x, y, k, n As Long, nn As Long, m As Long Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") Set re = CreateObject("VBScript.RegExp") re.Pattern = "\d+$" arr2 = Sheets("Лист 1").Range("A2:C" & Sheets("Лист 1").Cells(Rows.Count, 1).End(xlUp).Row).Value arr1 = Sheets("Лист 2").Range("A2:C" & Sheets("Лист 2").Cells(Rows.Count, 1).End(xlUp).Row).Value For n = 1 To UBound(arr1) col = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If re.Test(arr1(n, 3)) Then m = CLng(re.Execute(arr1(n, 3)).Item(0)) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(col) Then Set dic1(arr1(n, 1))(col) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1))(col).exists(m) Then dic1(arr1(n, 1))(col).Add m, arr1(n, 2) Else Do While dic1(arr1(n, 1))(col).exists(m) m = m + 1 Loop dic1(arr1(n, 1))(col).Add m, arr1(n, 2) End If arr1(n, 1) = "" End If Next For n = 1 To UBound(arr1) If arr1(n, 1) <> "" Then arr1(n, 3) = LCase(RTrim(re.Replace(Trim(arr1(n, 3)), ""))) If Not dic1.exists(arr1(n, 1)) Then Set dic1(arr1(n, 1)) = CreateObject("Scripting.dictionary") If Not dic1(arr1(n, 1)).exists(arr1(n, 3)) Then Set dic1(arr1(n, 1))(arr1(n, 3)) = CreateObject("Scripting.dictionary") For m = 1 To dic1(arr1(n, 1))(arr1(n, 3)).Count + 1 If Not dic1(arr1(n, 1))(arr1(n, 3)).exists(m) Then dic1(arr1(n, 1))(arr1(n, 3)).Add m, arr1(n, 2): Exit For Next End If Next For n = 1 To UBound(arr2) arr2(n, 3) = LCase(RTrim(re.Replace(Trim(arr2(n, 3)), ""))) If Not dic2.exists(arr2(n, 1)) Then Set dic2(arr2(n, 1)) = CreateObject("Scripting.dictionary") If Not dic2(arr2(n, 1)).exists(arr2(n, 3)) Then Set dic2(arr2(n, 1))(arr2(n, 3)) = CreateObject("Scripting.dictionary") nn = 0 If dic1.exists(arr2(n, 1)) Then If dic1(arr2(n, 1)).exists(arr2(n, 3)) Then nn = dic1(arr2(n, 1))(arr2(n, 3)).Count For m = 1 To nn + 1 + dic2(arr2(n, 1))(arr2(n, 3)).Count + 1 If nn = 0 Then If Not dic2(arr2(n, 1))(arr2(n, 3)).exists(m) Then dic2(arr2(n, 1))(arr2(n, 3)).Add m, arr2(n, 2): Exit For Else If Not dic2(arr2(n, 1))(arr2(n, 3)).exists(m) And Not dic1(arr2(n, 1))(arr2(n, 3)).exists(m) Then dic2(arr2(n, 1))(arr2(n, 3)).Add m, arr2(n, 2): Exit For End If Next Next n = 1 For Each y In dic1 For Each x In dic1(y) For Each k In dic1(y)(x) arr1(n, 1) = y arr1(n, 2) = dic1(y)(x).Item(k) arr1(n, 3) = x & " " & k n = n + 1 Next Next Next n = 1 For Each y In dic2 For Each x In dic2(y) For Each k In dic2(y)(x) arr2(n, 1) = y arr2(n, 2) = dic2(y)(x).Item(k) arr2(n, 3) = x & " " & k n = n + 1 Next Next Next dic1.RemoveAll dic2.RemoveAll Sheets("Лист 1").Range("E2").Resize(UBound(arr2), 3) = arr2 Sheets("Лист 2").Range("E2").Resize(UBound(arr1), 3) = arr1 End Sub
[/vba] Для лучшего понимания таблицу с результатом вставил рядомmsi2102
вариант PQ. Регистр игнориуется, а то у вас встречаются "белый" и "Белый". [vba]
Код
let // группируем 1-й список по коду SL1 = Excel.CurrentWorkbook(){[Name="Table1"]}[Content], ct1 = Table.TransformColumnTypes(SL1,{{"Группировочный код", type text}}), g1 = Table.Group(ct1, {"Группировочный код"}, {{"L1", each _}}), // группируем 2-й список по коду и формируем record SL2 = Excel.CurrentWorkbook(){[Name="Table2"]}[Content], ct2 = Table.TransformColumnTypes(SL2,{{"Группировочный код", type text}}), g2 = Table.Group(ct2, {"Группировочный код"}, {{"L2", each _}}), r2 = Record.FromList(g2[L2], g2[Группировочный код] ), // list_12 - добавляем цвета из 2-й таблицы для сравнения null_r = [Цвет = {""}], list_12 = Table.Buffer(Table.AddColumn(g1, "L2", each Record.FieldOrDefault(r2, [Группировочный код], null_r)[Цвет])), // функция перебора и изменения цветов таблиц из списка 1 txform_colors = (tbl_01 as table, lst_02 as list) => let lst_01 = tbl_01[Цвет], max_01 = List.Count(lst_01), txf = List.Generate( () => [i = -1, clr = {}, test_colors = lst_02], (x) => x[i] < max_01, (x) => let a = x[i] + 1, b = find_color(lst_01{a}, x[test_colors], 0) in [i = a, clr = x[clr] & {b{0}}, test_colors = b{1}], (x) => x[clr] ), out = Table.FromColumns(List.RemoveLastN(Table.ToColumns(tbl_01), 1) & {List.Last(txf)}, Table.ColumnNames(tbl_01)) in out, // функция изменения цвета при сравнении со списком find_color = (color as text, c_list as list, n as any) as list => let new_color = if n = 0 then color else color & " " & Text.From(n) in if List.Contains(c_list, new_color, Comparer.OrdinalIgnoreCase) then @find_color(color, c_list, n + 1) else {new_color, c_list & {new_color}}, // запускаем txform_colors и кладем рез-т в новую колонку L3 = Table.AddColumn(list_12, "L3", (x) => txform_colors(x[L1], x[L2])), // выводим только новую колонку, собирая все таблицы воедино z = Table.Combine(L3[L3]) in z
[/vba]
вариант PQ. Регистр игнориуется, а то у вас встречаются "белый" и "Белый". [vba]
Код
let // группируем 1-й список по коду SL1 = Excel.CurrentWorkbook(){[Name="Table1"]}[Content], ct1 = Table.TransformColumnTypes(SL1,{{"Группировочный код", type text}}), g1 = Table.Group(ct1, {"Группировочный код"}, {{"L1", each _}}), // группируем 2-й список по коду и формируем record SL2 = Excel.CurrentWorkbook(){[Name="Table2"]}[Content], ct2 = Table.TransformColumnTypes(SL2,{{"Группировочный код", type text}}), g2 = Table.Group(ct2, {"Группировочный код"}, {{"L2", each _}}), r2 = Record.FromList(g2[L2], g2[Группировочный код] ), // list_12 - добавляем цвета из 2-й таблицы для сравнения null_r = [Цвет = {""}], list_12 = Table.Buffer(Table.AddColumn(g1, "L2", each Record.FieldOrDefault(r2, [Группировочный код], null_r)[Цвет])), // функция перебора и изменения цветов таблиц из списка 1 txform_colors = (tbl_01 as table, lst_02 as list) => let lst_01 = tbl_01[Цвет], max_01 = List.Count(lst_01), txf = List.Generate( () => [i = -1, clr = {}, test_colors = lst_02], (x) => x[i] < max_01, (x) => let a = x[i] + 1, b = find_color(lst_01{a}, x[test_colors], 0) in [i = a, clr = x[clr] & {b{0}}, test_colors = b{1}], (x) => x[clr] ), out = Table.FromColumns(List.RemoveLastN(Table.ToColumns(tbl_01), 1) & {List.Last(txf)}, Table.ColumnNames(tbl_01)) in out, // функция изменения цвета при сравнении со списком find_color = (color as text, c_list as list, n as any) as list => let new_color = if n = 0 then color else color & " " & Text.From(n) in if List.Contains(c_list, new_color, Comparer.OrdinalIgnoreCase) then @find_color(color, c_list, n + 1) else {new_color, c_list & {new_color}}, // запускаем txform_colors и кладем рез-т в новую колонку L3 = Table.AddColumn(list_12, "L3", (x) => txform_colors(x[L1], x[L2])), // выводим только новую колонку, собирая все таблицы воедино z = Table.Combine(L3[L3]) in z
elycioo, возможно, т.к. у меня файл работает без ошибок. Запустите обновление офиса (не версию поменять, а все доступные для вашей версии обновления установить).
elycioo, возможно, т.к. у меня файл работает без ошибок. Запустите обновление офиса (не версию поменять, а все доступные для вашей версии обновления установить).AlienSphinx
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
