Добрый день, друзья. Помогите в моей нелёгкой задачке: нужно из ячеек столбца А вырезать адрес электронной почты в соответствующие ячейки столбца B. Адрес электронной почты непременно включает в себя символ СОБАЧКА и не имеет пробелов
ЗЫ: ячейки столбца А имеют произвольное количество символов и представляют из себя набор почтового адреса, номера телефона и адреса электронной почты
Спасибо
Добрый день, друзья. Помогите в моей нелёгкой задачке: нужно из ячеек столбца А вырезать адрес электронной почты в соответствующие ячейки столбца B. Адрес электронной почты непременно включает в себя символ СОБАЧКА и не имеет пробелов
ЗЫ: ячейки столбца А имеют произвольное количество символов и представляют из себя набор почтового адреса, номера телефона и адреса электронной почты
Без примера вариант "текст по столбцам". Если макросом, то [vba]
Код
Sub Main() Dim i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), " ") For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b End Sub
[/vba] Найден за минуту поиска в яндексе с запросом "копирование слова по символу vba" Автор SAS888
Без примера вариант "текст по столбцам". Если макросом, то [vba]
Код
Sub Main() Dim i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), " ") For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b End Sub
[/vba] Найден за минуту поиска в яндексе с запросом "копирование слова по символу vba" Автор SAS888SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Среда, 17.07.2013, 13:09
Например, в А1 содержится: 664033 Россия, г. Иркутск, ул. Лермонтова, 132, оф.9; (3952) 51-06-86, 609-809; tretyakov_ko@mail.ru в А2: 305023, г.Курск, ул. 1-я Прогонная, д.65, тел. (4712) 50-25-93, т./ф. 50-25-89,FSK_Perspektiva@bk.ru
Нужно из А1 вырезать электронную почту в B1, из А2 в В2
Например, в А1 содержится: 664033 Россия, г. Иркутск, ул. Лермонтова, 132, оф.9; (3952) 51-06-86, 609-809; tretyakov_ko@mail.ru в А2: 305023, г.Курск, ул. 1-я Прогонная, д.65, тел. (4712) 50-25-93, т./ф. 50-25-89,FSK_Perspektiva@bk.ru
Нужно из А1 вырезать электронную почту в B1, из А2 в В2Александр
Но как сделать чтобы не копировал а вырезал эту почту и вставил во второй столбик?! И как добавить в условие чтобы макрос смотрел не только по пробелу, а по запятой тоже?
Спасибо! Работает!!
Но как сделать чтобы не копировал а вырезал эту почту и вставил во второй столбик?! И как добавить в условие чтобы макрос смотрел не только по пробелу, а по запятой тоже?Александр
Как, как... Регэкспами. Впрочем, я бы просто находил СОБАЧКУ и искал бы по набору ограничителей слева и справа. Вот только фантазии пользователей доходят до того, что они и букву "Ы" перед адресом готовы считать разделителем...
Между прочим, некоторые почтовые сервисы бывают не готовы считать подчёркивание за самостоятельны валидный символ...
Как, как... Регэкспами. Впрочем, я бы просто находил СОБАЧКУ и искал бы по набору ограничителей слева и справа. Вот только фантазии пользователей доходят до того, что они и букву "Ы" перед адресом готовы считать разделителем...
Между прочим, некоторые почтовые сервисы бывают не готовы считать подчёркивание за самостоятельны валидный символ...AndreTM
Для одноразового решения можно просто заменить все запятые и точки с запятой пробелами. После чего запустить макрос. В адресе почты не может быть запятых и точек с запятой. Останется только проблема с точками
В макросе, подозреваю, вот эта строка отвечает за разделитель : [vba]
Код
c = Split(Application.Trim(a(i, 1)), " ")
[/vba] Попробуйте в несколько циклов. Сначала один разделитель, потом второй и т.д. У меня так получилось.
Для одноразового решения можно просто заменить все запятые и точки с запятой пробелами. После чего запустить макрос. В адресе почты не может быть запятых и точек с запятой. Останется только проблема с точками
В макросе, подозреваю, вот эта строка отвечает за разделитель : [vba]
Код
c = Split(Application.Trim(a(i, 1)), " ")
[/vba] Попробуйте в несколько циклов. Сначала один разделитель, потом второй и т.д. У меня так получилось.SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Среда, 17.07.2013, 13:53
А если разрешат пробелы в адресе?? В результате - задача превращается в квест. Нет, чтобы сразу определить ввод данных в базу по полям... Ну, по сущностям в базе - и контроль ввода прямо на клиенте.
А если разрешат пробелы в адресе?? В результате - задача превращается в квест. Нет, чтобы сразу определить ввод данных в базу по полям... Ну, по сущностям в базе - и контроль ввода прямо на клиенте.AndreTM
Ну в том примере, что указал ТС есть только запятая и точка с запятой. Остальное вручную.
По поводу удаления мейла из А:А : [vba]
Код
Sub Main() Dim razdelitel$, i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) razdelitel = InputBox(prompt:="Введите разделитель:", Title:="Разделитель") For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), razdelitel) For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b
Dim rCell As Range, rBB As Range, text$, rA As Range Set rBB = ActiveSheet.Range([B1], Cells(Rows.Count, 2).End(xlUp)) For Each rCell In rBB text = rCell.Value If text <> "" Then Set rA = rCell.Offset(0, -1) rA.Replace What:=text, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows End If Next End Sub
[/vba]
Ну в том примере, что указал ТС есть только запятая и точка с запятой. Остальное вручную.
По поводу удаления мейла из А:А : [vba]
Код
Sub Main() Dim razdelitel$, i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) razdelitel = InputBox(prompt:="Введите разделитель:", Title:="Разделитель") For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), razdelitel) For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b
Dim rCell As Range, rBB As Range, text$, rA As Range Set rBB = ActiveSheet.Range([B1], Cells(Rows.Count, 2).End(xlUp)) For Each rCell In rBB text = rCell.Value If text <> "" Then Set rA = rCell.Offset(0, -1) rA.Replace What:=text, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows End If Next End Sub
Sub Main() Dim i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False Columns("A:A").Replace What:=",", Replacement:=", " Columns("A:A").Replace What:=";", Replacement:="; " a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) Range([A1], Cells(Rows.Count, 1).End(xlUp)).Replace What:=";", Replacement:="; ", LookAt:=xlPart, SearchOrder:=xlByRows For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), " ") For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b
Dim rCell As Range, rBB As Range, text$, rA As Range Set rBB = ActiveSheet.Range([B1], Cells(Rows.Count, 2).End(xlUp)) For Each rCell In rBB text = rCell.Value If text <> "" Then Set rA = rCell.Offset(0, -1) rA.Replace What:=text, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows End If Next End Sub
[/vba]
[vba]
Код
Sub Main() Dim i As Long, j As Integer, a(), b(), c: Application.ScreenUpdating = False Columns("A:A").Replace What:=",", Replacement:=", " Columns("A:A").Replace What:=";", Replacement:="; " a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 1) Range([A1], Cells(Rows.Count, 1).End(xlUp)).Replace What:=";", Replacement:="; ", LookAt:=xlPart, SearchOrder:=xlByRows For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then c = Split(Application.Trim(a(i, 1)), " ") For j = LBound(c) To UBound(c) If InStr(c(j), "@") <> 0 Then b(i, 1) = b(i, 1) & " " & c(j) Next: b(i, 1) = Trim(b(i, 1)) End If: Next: [B1].Resize(UBound(b, 1)).Value = b
Dim rCell As Range, rBB As Range, text$, rA As Range Set rBB = ActiveSheet.Range([B1], Cells(Rows.Count, 2).End(xlUp)) For Each rCell In rBB text = rCell.Value If text <> "" Then Set rA = rCell.Offset(0, -1) rA.Replace What:=text, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows End If Next End Sub
Добрый день. А как быть если у меня одна ячейка с e-mail адресами ( zzzzzz@mail.ru ; сссссс@mail.com; и тд) Как мне из эту ячейку превратить в столбец с отдельными адресами?
Добрый день. А как быть если у меня одна ячейка с e-mail адресами ( zzzzzz@mail.ru ; сссссс@mail.com; и тд) Как мне из эту ячейку превратить в столбец с отдельными адресами?vsalitanov
With CreateObject("vbscript.regexp") .Pattern = EML_PTRN .Global = True .IgnoreCase = True Set v = .Execute(S) End With For Each el In v t = t & ", " & el Next em = Mid(t, 3) End Function
[/vba]
vsalitanov - Ваш вопрос к теме не относится, Вам нужно создать свою тему. Т.к. судя по Вашему примеру - извлекать именно емайлы тут не нужно, это не суть задачи.
Всё давно уже написано... Это извлечение эмайлов - раз уж тут пока небыло решения на regexp. [vba]
Код
Function em(S As String) Dim v, el, t$ Dim EML_PTRN$
With CreateObject("vbscript.regexp") .Pattern = EML_PTRN .Global = True .IgnoreCase = True Set v = .Execute(S) End With For Each el In v t = t & ", " & el Next em = Mid(t, 3) End Function
[/vba]
vsalitanov - Ваш вопрос к теме не относится, Вам нужно создать свою тему. Т.к. судя по Вашему примеру - извлекать именно емайлы тут не нужно, это не суть задачи.Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
и искал бы по набору ограничителей слева и справа. 
