Разделить данные в нескольких ячейках на строки - VBA

Узнай цену своей работы

Формулировка задачи:

Добрый день! Пожалуйста помогите, решить следующую проблему: Есть таблица с данными, в которой в 2-х ячейках есть данные разделенные с помощью ;" Необходимо выделить данные из ячеек в строки ниже с копированием информации из других ячеек Например: [Номер][Строка][Персона1;Персона2;Персона3][Документ1;Документ2;Документ3] нужно привести к следующему виду: [Номер][Строка][Персона1][Документ1] [Номер][Строка][Персона2][Документ2] [Номер][Строка][Персона3][Документ3] Пример в прикрепленном файле (извините за неудобный вид, пришлось скрыть личные данные), отвечу на любые вопросы. Буду очень благодарен за помощь.

Решение задачи: «Разделить данные в нескольких ячейках на строки»

textual
Листинг программы
  1. Option Explicit
  2.  
  3. Sub qwert()
  4. Dim r!, c!, m(), lr!, lc!, rn!, c1!, c2!, rz(), ri!, u1, u2, ii
  5. c1 = 7 '
  6. c2 = 8 '
  7. With Лист1
  8.     lr = .Cells(.Rows.Count, 1).End(xlUp).Row
  9.     lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
  10.     m = .[a1].Resize(lr, lc).Value
  11.     For r = 1 To UBound(m): lr = lr + UBound(Split(m(r, c1), ";")): Next
  12.     ReDim rz(1 To lr, 1 To lr)
  13.     For r = 1 To UBound(m)
  14.         If InStr(1, m(r, c1), ";") > 0 Then
  15.             u1 = Split(m(r, c1), ";")
  16.             u2 = Split(m(r, c2), ";")
  17.             If UBound(u1) <> UBound(u2) Then MsgBox "В строке " & r & " несоответсвие", vbCritical, ""
  18.             For ii = 0 To UBound(u1)
  19.                 If Len(u1(ii)) > 0 Then
  20.                     ri = ri + 1
  21.                     For c = 1 To lc
  22.                         rz(ri, c) = m(r, c)
  23.                     Next c
  24.                     rz(ri, c1) = u1(ii)
  25.                     rz(ri, c2) = u2(ii)
  26.                 End If
  27.             Next ii
  28.         Else
  29.             ri = ri + 1
  30.             For c = 1 To lc
  31.                 rz(ri, c) = m(r, c)
  32.             Next c
  33.         End If
  34.     Next r
  35.     .[a1].Resize(lr, lc) = rz
  36. End With
  37. End Sub

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

8   голосов , оценка 3.625 из 5

Нужна аналогичная работа?

Оформи быстрый заказ и узнай стоимость

Бесплатно
Оформите заказ и авторы начнут откликаться уже через 10 минут
Похожие ответы