Перенести содержимое обнаруженных дублей столбца "A" в - VBA
Формулировка задачи:
Добрый вечер!
Имеется excel файл со структурой напечатанной ниже:
Столбец "A"
- Артикула товара;Столбцы начиная от "B"
- Свойства товара;Строка "1"
- Название свойства (кроме ячейки "А1" - в ней надпись - Артикул);Строки начиная со "2"
- Содержание свойства (кроме ячеек столбца "А" - в них - Артикул);. В файле около 2 тыс. столбцов и около 100 тыс. строк. Сейчас файл построен таким образом, что для каждого свойства идёт своя строка с артикулом. Таким образом один и тот же артикул, к примеру 4887, может быть на десятке строк, пример печатаю ниже: [A7] 4887 [B7] красный [A11] 4887 [I11] жёлтый [A13] 4887 [KK13] фиолетовый - Напечатайте пожалуйста макрос, которыйперенесёт содержание строк дублей по столбцу "A" в первый имеющийся экземпляр артикула
. Пример необходимого результат печатаю ниже: [A7] 4887 [B7] красный [I11] жёлтый [KK13] фиолетовый В файле во вложении прикрепляю файл содержащий страницы затрагивающие этот топик:необходимый результат
инеобходимый результат-2
.Решение задачи: «Перенести содержимое обнаруженных дублей столбца "A" в»
textual
Листинг программы
Sub Заполнение_свойств_2() Dim i&, j&, k&, LastCol&, Ar, B, Dic_a, Dic_s, Dic_z, vX, S$ Dim u_a, u_s, rz(), r, c Ar = Worksheets(1).[A1].CurrentRegion.Value Set Dic_a = CreateObject("Scripting.Dictionary"): Dic_a.CompareMode = 1 Set Dic_s = CreateObject("Scripting.Dictionary"): Dic_s.CompareMode = 1 ' Set Dic_z = CreateObject("Scripting.Dictionary"): Dic_z.CompareMode = 1 For i = 1 To UBound(Ar) If IsNumeric(Ar(i, 1)) Then Ar(i, 1) = Format$(Ar(i, 1)) If Not Dic_a.exists(Ar(i, 2)) Then Dic_a(Ar(i, 1)) = Dic_a.Count + 1 If Not Dic_s.exists(Ar(i, 2)) Then Dic_s(Ar(i, 2)) = Dic_s.Count + 1 Next i ReDim rz(1 To Dic_a.Count + 1, 1 To Dic_s.Count + 2) For i = 1 To UBound(Ar) r = Dic_a(Ar(i, 1)) c = Dic_s(Ar(i, 2)) + 1 rz(r, 1) = Ar(i, 1) rz(1, c) = Ar(i, 2) rz(r, c) = Ar(i, 3) Next i With Worksheets(4) .UsedRange.ClearContents .Range("A1").Resize(UBound(rz), UBound(rz, 2)) = rz End With Set Dic1 = Nothing: Set Dic2 = Nothing ': Set Dic3 = Nothing End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д