Есть список с названием компаний и их электронными адресами. В данных некоторых компаний попадаются (в одной ячейке) по 2-6 e-mail, нужно разделить адреса по разным строкам и сделать так чтобы наименование компании дублировалось на ячейку ниже и к ней привязывался электронный адрес, т.е. если в списке под одной компанией 3 адреса, то компания должна быть 3 раза продублирована с разными адресами, при этом если адрес один, то никакого дубля быть не должно. Пример в файле, как есть и как должно быть. Список который необходимо разделить содержит более 17 054 компании, так что без помощи перебирать все вручную туго.javascript:; К сообщению приложен файл "образец". В файле "тест" пробовал подставить формулы, тоже прикрепил.javascript:;
Здравствуйте! Нужна помощь новичку.
Есть список с названием компаний и их электронными адресами. В данных некоторых компаний попадаются (в одной ячейке) по 2-6 e-mail, нужно разделить адреса по разным строкам и сделать так чтобы наименование компании дублировалось на ячейку ниже и к ней привязывался электронный адрес, т.е. если в списке под одной компанией 3 адреса, то компания должна быть 3 раза продублирована с разными адресами, при этом если адрес один, то никакого дубля быть не должно. Пример в файле, как есть и как должно быть. Список который необходимо разделить содержит более 17 054 компании, так что без помощи перебирать все вручную туго.javascript:; К сообщению приложен файл "образец". В файле "тест" пробовал подставить формулы, тоже прикрепил.javascript:;Vladimir9961
Sub Макрос2() Dim arr1, arr2, n As Long, m As Long, k As Long, i As Long arr1 = Worksheets("Данные").Range("A1:V" & Worksheets("Данные").Cells(Rows.Count, 1).End(xlUp).Row) m = 1 For n = 2 To UBound(arr1) a = Split(arr1(n, 11), ",") m = m + UBound(Split(arr1(n, 11), ",")) + 1 arr1(n, 22) = a Next ReDim arr2(1 To m + 1, 1 To UBound(arr1, 2) - 1) k = 1 For n = 1 To UBound(arr1) If k = 1 Then arr2(k, 1) = arr1(n, 1): k = k + 1 Else For m = 0 To UBound(arr1(n, 22)) For i = 1 To UBound(arr1, 2) - 1 If i <> 11 Then arr2(k, i) = arr1(n, i) Else arr2(k, i) = Trim(arr1(n, 22)(m)) Next k = k + 1 Next End If Next Worksheets("Результат").Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 Worksheets("Результат").Select End Sub
[/vba]
VBA [vba]
Код
Sub Макрос2() Dim arr1, arr2, n As Long, m As Long, k As Long, i As Long arr1 = Worksheets("Данные").Range("A1:V" & Worksheets("Данные").Cells(Rows.Count, 1).End(xlUp).Row) m = 1 For n = 2 To UBound(arr1) a = Split(arr1(n, 11), ",") m = m + UBound(Split(arr1(n, 11), ",")) + 1 arr1(n, 22) = a Next ReDim arr2(1 To m + 1, 1 To UBound(arr1, 2) - 1) k = 1 For n = 1 To UBound(arr1) If k = 1 Then arr2(k, 1) = arr1(n, 1): k = k + 1 Else For m = 0 To UBound(arr1(n, 22)) For i = 1 To UBound(arr1, 2) - 1 If i <> 11 Then arr2(k, i) = arr1(n, i) Else arr2(k, i) = Trim(arr1(n, 22)(m)) Next k = k + 1 Next End If Next Worksheets("Результат").Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 Worksheets("Результат").Select End Sub
Скачайте файл, откройте, нажмите на кнопку и будет чудо. А если совсем не знаете, что это такое, то гуглите или яндексите: "Макрос EXCEL, что это такое"
Скачайте файл, откройте, нажмите на кнопку и будет чудо. А если совсем не знаете, что это такое, то гуглите или яндексите: "Макрос EXCEL, что это такое"msi2102
Сообщение отредактировал msi2102 - Четверг, 22.06.2023, 16:25