Добрый день! Подскажите, пожалуйста, можно ли из первого столбца с разной информацией во второй столбец скопировать только ФИО сотрудника. В таблице видно содержимое первого столбца: ФИО может быть с пробелом в конце, что нельзя допустить. Либо с адресом почты, а у некоторых сотрудников может не быть отчества, либо наоборот, больше трех слов. Заранее спасибо.
Можно получится такой код Sub ExtractNames() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim fullName As String Dim cleanedName As String Dim words() As String Dim j As Long
' Установим ссылку на активный лист Set ws = ThisWorkbook.Sheets("Лист1")
' Определим последнюю строку в первом столбце lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Проходим по каждой строке в столбце A For i = 1 To lastRow fullName = ws.Cells(i, 1).Value
' Удалим адрес электронной почты, если он присутствует If InStr(fullName, "@") > 0 Then fullName = Left(fullName, InStr(fullName, "@") - 1) End If
' Удалим лишние пробелы в начале и в конце строки cleanedName = Application.WorksheetFunction.Trim(fullName)
' Разобьём строку на слова words = Split(cleanedName, " ")
' Сформируем ФИО на основе первых 2-3 слов (имя, фамилия, отчество, если есть) cleanedName = "" For j = LBound(words) To UBound(words) If Len(cleanedName) > 0 Then cleanedName = cleanedName & " " End If cleanedName = cleanedName & words(j) ' Остановимся после третьего слова (ФИО) If j >= 2 Then Exit For Next j
' Запишем результат во второй столбец ws.Cells(i, 2).Value = cleanedName Next i End Sub
1. Здесь я использовал UDF проверки наличия латиницы, взятую в разделе приёмов этого сайта 2. Создал дополнительный (вспомогательный) лист 3. В формуле исходил из максимум 4 слов в ячейке, как в примере
Объединил свой код с кодом DAB Sub ExtractNamesAndHighlightLatin() Dim ws As Worksheet Dim lastRow As Long Dim i As Long, j As Long Dim fullName As String Dim cleanedName As String Dim words() As String Dim LatinAlphbet As String Dim char As String
' Установим ссылку на активный лист Set ws = ThisWorkbook.Sheets("Лист1")
' Определим последнюю строку в первом столбце lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Проходим по каждой строке в столбце A For i = 1 To lastRow fullName = ws.Cells(i, 1).Value
' Удалим адрес электронной почты, если он присутствует If InStr(fullName, "@") > 0 Then fullName = Left(fullName, InStr(fullName, "@") - 1) End If
' Удалим лишние пробелы в начале и в конце строки cleanedName = Application.WorksheetFunction.Trim(fullName)
' Разобьём строку на слова words = Split(cleanedName, " ")
' Сформируем ФИО на основе первых 2-3 слов (имя, фамилия, отчество, если есть) cleanedName = "" For j = LBound(words) To UBound(words) If Len(cleanedName) > 0 Then cleanedName = cleanedName & " " End If cleanedName = cleanedName & words(j) ' Остановимся после третьего слова (ФИО) If j >= 2 Then Exit For Next j
' Запишем результат во второй столбец ws.Cells(i, 2).Value = cleanedName
' Теперь проверим на наличие латинских символов и выделим их LatinAlphbet = "*[abcdefghijklmnopqrstuvwxyz]*" If cleanedName Like LatinAlphbet Then For j = 1 To Len(cleanedName) char = Mid(cleanedName, j, 1) If IsLatin(char) Then ws.Cells(i, 2).Characters(Start:=j, Length:=1).Font.ColorIndex = 3 End If Next j End If Next i End Sub
Function IsLatin(char As String) As Boolean char = LCase(char) LatinAlphbet = "*[abcdefghijklmnopqrstuvwxyz]*" If char Like LatinAlphbet Then IsLatin = True Else IsLatin = False End If End Function