Макрос для переноса свойств по столбцам - VBA
Формулировка задачи:
Добрый день!
Имеется excel файл напечатанного ниже формата:
Столбец "A"
- артикул (служит идентификатором, повторяется для разных свойств);Столбец "B"
- название свойства;Столбец "С"
- описание свойства. Пример файла с повторяющимися артикулами для разных свойств:-
299571
LCD-дисплей: нет - 488447 LCD-дисплей: нет
- 488445 LCD-дисплей: нет
- 488444 LCD-дисплей: нет
- 253331 LCD-дисплей: нет
- 488446 LCD-дисплей: нет
- 336157 LCD-дисплей: нет
- 466206 LCD-дисплей: нет
- 120312 LCD-дисплей: нет
- 451045 LCD-дисплей: нет
- 471524 LCD-дисплей: нет
- 491343 LCD-дисплей: да
- 471522 LCD-дисплей: нет
-
299571
Страна: Франция - 488447 Страна: Франция
- 488445 Страна: Португалия
- 488444 Страна: Швейцария
- 253331 Страна: Португалия
- 488446 Страна: Румыния
- 336157 Страна: Румыния
- 466206 Страна: Румыния
- 120312 Страна: Румыния
- 451045 Страна: Румыния
- 471524 Страна: Румыния
- 491343 Страна: Италия
- 471522 Страна: Румыния
столбца "B"
оставит только уникальные значения, - которые будут размещаться по порядку на первой строке, начиная состолбца "B"
, продолжаястолбцом "C"
,столбцом "D"
и так далее в зависимости от количества найденных уникальныхназваний свойств
; 2. Встолбце "A"
начиная со второй строки будут размещатьсяартикула
; 3. Начиная состолбца "B"
и до последнего существующего, и начиная со второй ячейки до последней существующей, будут размещаться описания свойств, - размещение которых зависит от размещенияартикула
. Пример необходимого результат, напечатан ниже:- Артикул: LCD-дисплей: Страна:
-
299571
нет - 488447 нет
- 488445 нет
- 488444 нет
- 253331 нет
- 488446 нет
- 336157 нет
- 466206 нет
- 120312 нет
- 451045 нет
- 471524 нет
- 491343 да
- 471522 нет
-
299571
Франция - 488447 Франция
- 488445 Португалия
- 488444 Швейцария
- 253331 Португалия
- 488446 Румыния
- 336157 Румыния
- 466206 Румыния
- 120312 Румыния
- 451045 Румыния
- 471524 Румыния
- 491343 Италия
- 471522 Румыния
Решение задачи: «Макрос для переноса свойств по столбцам»
textual
Листинг программы
- Sub Заполнение_свойств()
- Dim i&, j&, k&, LastCol&, Ar, B, Dic1, Dic2, Dic3, vX, S$
- Ar = Worksheets(1).[A1].CurrentRegion.Value
- Set Dic1 = CreateObject("Scripting.Dictionary"): Dic1.CompareMode = 1
- Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
- Set Dic3 = CreateObject("Scripting.Dictionary"): Dic3.CompareMode = 1
- For i = 1 To UBound(Ar)
- If IsNumeric(Ar(i, 1)) Then Ar(i, 1) = format$(Ar(i, 1))
- S = Ar(i, 1) & Ar(i, 2)
- Dic1(S) = Ar(i, 3)
- Dic2(Ar(i, 1)) = 0&
- Dic3(Ar(i, 2)) = 0&
- Next i
- With Worksheets(2)
- .UsedRange.ClearContents
- i = 1
- For Each vX In Dic2.Keys
- i = i + 1
- .Cells(i, 1) = vX
- Next
- .[A1] = "Артикул:"
- B = .Range("A2:A" & i).Value
- j = 1
- For Each vX In Dic3.Keys
- j = j + 1
- .Cells(1, j) = vX
- Next
- LastCol = j
- i = 1
- For j = 2 To LastCol
- For k = 1 To UBound(B)
- i = i + 1
- .Cells(i, 1) = B(k, 1)
- If IsNumeric(B(k, 1)) Then S = format$(B(k, 1)) Else S = B(k, 1)
- S = S & .Cells(1, j)
- If Dic1.Exists(S) Then .Cells(i, j) = Dic1(S)
- Next
- Next
- End With
- Set Dic1 = Nothing: Set Dic2 = Nothing: Set Dic3 = Nothing
- End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д