Разделить данные в нескольких ячейках на строки - VBA
Формулировка задачи:
Добрый день!
Пожалуйста помогите, решить следующую проблему:
Есть таблица с данными, в которой в 2-х ячейках есть данные разделенные с помощью ;"
Необходимо выделить данные из ячеек в строки ниже с копированием информации из других ячеек
Например:
[Номер][Строка][Персона1;Персона2;Персона3][Документ1;Документ2;Документ3]
нужно привести к следующему виду:
[Номер][Строка][Персона1][Документ1]
[Номер][Строка][Персона2][Документ2]
[Номер][Строка][Персона3][Документ3]
Пример в прикрепленном файле (извините за неудобный вид, пришлось скрыть личные данные), отвечу на любые вопросы.
Буду очень благодарен за помощь.
Решение задачи: «Разделить данные в нескольких ячейках на строки»
textual
Листинг программы
- Option Explicit
- Sub qwert()
- Dim r!, c!, m(), lr!, lc!, rn!, c1!, c2!, rz(), ri!, u1, u2, ii
- c1 = 7 '
- c2 = 8 '
- With Лист1
- lr = .Cells(.Rows.Count, 1).End(xlUp).Row
- lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
- m = .[a1].Resize(lr, lc).Value
- For r = 1 To UBound(m): lr = lr + UBound(Split(m(r, c1), ";")): Next
- ReDim rz(1 To lr, 1 To lr)
- For r = 1 To UBound(m)
- If InStr(1, m(r, c1), ";") > 0 Then
- u1 = Split(m(r, c1), ";")
- u2 = Split(m(r, c2), ";")
- If UBound(u1) <> UBound(u2) Then MsgBox "В строке " & r & " несоответсвие", vbCritical, ""
- For ii = 0 To UBound(u1)
- If Len(u1(ii)) > 0 Then
- ri = ri + 1
- For c = 1 To lc
- rz(ri, c) = m(r, c)
- Next c
- rz(ri, c1) = u1(ii)
- rz(ri, c2) = u2(ii)
- End If
- Next ii
- Else
- ri = ri + 1
- For c = 1 To lc
- rz(ri, c) = m(r, c)
- Next c
- End If
- Next r
- .[a1].Resize(lr, lc) = rz
- End With
- End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д