Разделить данные в нескольких ячейках на строки - 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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д