Страницы: 1
RSS
Из списка сотрудников выбрать в отдельный столбец только ФИО., Из списка сотрудников выбрать в отдельный столбец только ФИО.
 
Добрый день! Подскажите, пожалуйста, можно ли из первого столбца с разной информацией во второй столбец скопировать только ФИО сотрудника. В таблице видно содержимое первого столбца: ФИО может быть с пробелом в конце, что нельзя допустить. Либо с адресом почты, а у некоторых сотрудников может не быть отчества, либо наоборот, больше трех слов. Заранее спасибо.
Изменено: Vallarius - 12.10.2024 14:28:59
 
Можно получится такой код
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 - 14.10.2024 16:29:06
 
Огромное вам всем спасибо! Все работает!!!
 
Как-то так:
Код
=IFERROR(LEFT(TRIM(LEFT(A2;FIND("^";SUBSTITUTE(A2;"@";"^";LEN(A2)-LEN(SUBSTITUTE(A2;"@";""))))-1));LEN(A2)-LEN(TRIM(RIGHT(SUBSTITUTE(A2;" ";REPT(" ";255));255)))-1);A2)
 
Очень вам признателен!!!
 
Объединил свой код с кодом 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
 
Супер!!!
 
tserv2204, код в сообщении следует оформлять соответствующим тэгом (<...>)
Согласие есть продукт при полном непротивлении сторон
 
Ну и еще напоследок для Excel 2021-2024-365
=TEXTAFTER(A1;" ";LEN(A1)-LEN(SUBSTITUTE(A1;" ";""));1;1)
Изменено: memo - 14.10.2024 15:24:18
Страницы: 1
Наверх