Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сортировка по фамилиям без учета инициалов
 
#1
17.09.2021 18:10:28
Добрый день.

Существует проблема. Список сотрудников (более 200 человек) в формате "И. О. Фамилия", т.е. сначала идут инициалы, затем фамилия.

Задача - отсортировать список по алфавиту по критерию фамилии средствами VBA.
Знаю, что можно разделить данные по столбцам, потом сортировать диапазон, потом собрать все снова в один столбец, но это "костылинг". Есть идеи?

Файл для примера прилагаю.
Изменено: vikttur - 17.09.2021 20:34:03
 
 
 
#2
17.09.2021 18:24:23
Доброго дня!
Цитата
Aiden_ko написал: отсортировать список ... средствами VBA
Есть решение на PQ. Надо? или только vba рассматриваете?
Вдруг, кому-то понадобится...
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    #"Вставленный текст после разделителя" = Table.AddColumn(Источник, "Текст после разделителя", each Text.AfterDelimiter([Столбец1], ". ", {0, RelativePosition.FromEnd}), type text),
    #"Сортированные строки" = Table.Sort(#"Вставленный текст после разделителя",{{"Текст после разделителя", Order.Ascending}}),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Сортированные строки",{"Текст после разделителя"})
in
    #"Удаленные столбцы"
Изменено: vikttur - 17.09.2021 20:34:49
 
 
 
#3
17.09.2021 18:24:50
если excel 365:
=СОРТПО(D5:D10;ПСТР(D5:D10;7;99))
 
 
 
#4
17.09.2021 18:43:05
Цитата
alexleoix написал: Есть решение на PQ. Надо? или только vba рассматриваете?
Только VBA, надо вписать в существующий уже большой проект.

Цитата
Бахтиёр написал: если excel 365:=СОРТПО(D5:D10;ПСТР(D5:D10;7;99))
Ecxel 2019, и надо решить вопрос не формулой на листе, а через VBA
 
 
 
#5
17.09.2021 20:41:42
ну через адо  (Это черновик)
Скрытый текст
По вопросам из тем форума, личку не читаю.
 
 
 
#6
18.09.2021 04:01:24
Aiden_ko,  

Код
Sub SortBySurname()
    Dim arrNames(), i As Long, lngSpacePos As Long, strName As String

    With ActiveSheet
        arrNames = .Range("D5:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value2
        For i = 1 To UBound(arrNames)
            strName = Application.Trim(arrNames(i, 1))
            lngSpacePos = InStrRev(strName, " ")
            arrNames(i, 1) = Mid(strName, lngSpacePos + 1, Len(strName)) & " " & Left(strName, lngSpacePos - 1)
        Next i
        Call uSort(arrNames, 1)
        For i = 1 To UBound(arrNames)
            lngSpacePos = InStr(1, arrNames(i, 1), " ", vbTextCompare)
            arrNames(i, 1) = Left(arrNames(i, 1), lngSpacePos) & Mid(arrNames(i, 1), lngSpacePos, Len(arrNames(i, 1)))
        Next i
        .Range("E5").Resize(UBound(arrNames, 1), 1).Value2 = arrNames
    End With
End Sub

Private Sub uSort(ByRef vArray(), Optional ColumnNumberToSortBy As Long = 1)
    Dim tempVal As String, iRow As Long, lowBound As Long, iCol As Long, i As Long
    If Not IsArray(vArray) Then Exit Sub
    lowBound = LBound(vArray)
    i = lowBound
    For iRow = lowBound + 1 To UBound(vArray)
        If vArray(iRow, ColumnNumberToSortBy) < vArray(i, ColumnNumberToSortBy) Then
            For iCol = 1 To UBound(vArray, 2)
                tempVal = vArray(i, iCol)
                vArray(i, iCol) = vArray(iRow, iCol)
                vArray(iRow, iCol) = tempVal
            Next
            iRow = i - 1
            i = iRow - 1
            If iRow < lowBound Then
                i = iRow
                iRow = lowBound
            End If
        End If
        i = i + 1
    Next iRow
End Sub
Изменено: New - 18.09.2021 04:14:45
 
 
 
#7
18.09.2021 12:16:33
New, все так, но одно НО, инициалы должны оставаться на своем месте, т.е. слева от фамилии.
 
 
 
#8
18.09.2021 13:47:44
Aiden_ko, ))) я так и хотел сделать, но видно отвлёкся, надо поправить 1 строку, вот код

Код
Sub SortBySurname()
    Dim arrNames(), i As Long, lngSpacePos As Long, strName As String
 
    With ActiveSheet
        arrNames = .Range("D5:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value2
        For i = 1 To UBound(arrNames)
            strName = Application.Trim(arrNames(i, 1))
            lngSpacePos = InStrRev(strName, " ")
            arrNames(i, 1) = Mid(strName, lngSpacePos + 1, Len(strName)) & " " & Left(strName, lngSpacePos - 1)
        Next i
        Call uSort(arrNames, 1)
        For i = 1 To UBound(arrNames)
            lngSpacePos = InStr(1, arrNames(i, 1), " ", vbTextCompare)
            arrNames(i, 1) = Mid(arrNames(i, 1), lngSpacePos + 1, Len(arrNames(i, 1))) & " " & Left(arrNames(i, 1), lngSpacePos)
        Next i
        .Range("E5").Resize(UBound(arrNames, 1), 1).Value2 = arrNames
    End With
End Sub
 
Private Sub uSort(ByRef vArray(), Optional ColumnNumberToSortBy As Long = 1)
    Dim tempVal As String, iRow As Long, lowBound As Long, iCol As Long, i As Long
    If Not IsArray(vArray) Then Exit Sub
    lowBound = LBound(vArray)
    i = lowBound
    For iRow = lowBound + 1 To UBound(vArray)
        If vArray(iRow, ColumnNumberToSortBy) < vArray(i, ColumnNumberToSortBy) Then
            For iCol = 1 To UBound(vArray, 2)
                tempVal = vArray(i, iCol)
                vArray(i, iCol) = vArray(iRow, iCol)
                vArray(iRow, iCol) = tempVal
            Next
            iRow = i - 1
            i = iRow - 1
            If iRow < lowBound Then
                i = iRow
                iRow = lowBound
            End If
        End If
        i = i + 1
    Next iRow
End Sub
Изменено: New - 18.09.2021 13:48:25
 
 
 
#9
18.09.2021 14:33:44
New, Гениально! Спасибо огромное! )))
 
 
 
#10
18.09.2021 18:30:06
чуть урезанный вариант
Код
Sub sort()
Dim oRecordSet As Object, oConn As Object
With ActiveSheet
    sTblQuery = "[" & .Name & "$" & .Range("D5:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).Address(False, False) & "]"
    Set oRecordSet = CreateObject("ADODB.Recordset")
    Set oConn = CreateObject("ADODB.Connection")
    oRecordSet.CursorLocation = 3
    sSQL_text = "SELECT * FROM " & sTblQuery & " ORDER BY MID(F1,7,255)"
    sConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO"";"
    oConn.Open sConnStr
    oRecordSet.Open sSQL_text, oConn
    .Range("F5").CopyFromRecordset oRecordSet
End With
End Sub
По вопросам из тем форума, личку не читаю.
 
 
 
#11
18.09.2021 19:30:21
С доп.столбцом по первым четырем буквам фамилий
НА МЯСО В ПРОФИЛЕ
 
 
 
#12
18.09.2021 19:48:22
настоятельно советую смотреть в сторону PQ.
там эта задача решается простейшим мышкоклацаньем
 
 
 
#13
18.09.2021 20:44:57
Цитата
ATK написал:
настоятельно советую смотреть в сторону PQ
прикольный настоятельный совет особенно после #2 и  
Цитата
Aiden_ko написал:
Только VBA, надо вписать в существующий уже большой проект.
По вопросам из тем форума, личку не читаю.
 
 
 
#14
18.09.2021 21:01:31
БМВ, это пранк, это пранк  :D  
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#15
18.09.2021 21:43:51
пранк пранком, а ADO  с сортировкой 2400 строк мгновенно справилась , примерно раз в 5 быстрее. хотя на малых объемах проигрывает.

240 строк
sort           0,078125
SortBySurname  0,0078125

2400
ort           0,1640625
SortBySurname  0,859375

А вот  24000
sort           0,703125
SortBySurname  94,16406

дальше не стал проверять ибо все печально и очевидно.
По вопросам из тем форума, личку не читаю.
 
 
 
#16
18.09.2021 21:50:21
ADO на малых объемах проигрывает, наверное, из-за CreateObject. А если сделать раннее связывание (добавить ссылку на библиотеку), то и на малых объемах будет быстрее
P.s. но надо следить, чтобы фамилия всегда начиналась с 7-го символа, и надеется, что никто не поставит где-нибудь 2 пробела вместо одного, а так же не забудет поставить 1 пробел между именем и отчеством
Изменено: New - 19.09.2021 02:50:59
 
 
 
#17
19.09.2021 08:29:28
Цитата
New написал:
P.s. но надо следить, чтобы фамилия всегда начиналась с 7-го символа,
пусть ADO следит
Код
    sSQL_text = "SELECT * FROM " & sTblQuery & " ORDER BY TRIM(RIGHT(REPLACE(REPLACE(F1,'.',' '),' ','                                        '),40))"

;)
Изменено: БМВ - 19.09.2021 08:29:54
По вопросам из тем форума, личку не читаю.
 
 
 
Страницы: 1
Наверх