Страницы: 1
RSS
Нестандартная сортировка: ФИО в разных ячейках
 
Всем доброго времени суток!

Прошу помощи!

Ситуация: Есть табеля учёта рабочего времени. Их много. В каждом может быть разное кол-во сотрудников. Нужно сделать сортировку по Фамилии в алфавитном порядке по возрастанию (с наименьшими действиями) с тем чтобы нужный диапазон вниз и вправо тоже захватывался.., скорее всего каким-либо макросом..К сожалению, не нашёл ничего подобного..( Проблема в том, что Фамилия, Имя, Отчество, Должность..это 4 отдельных строки и стандартной сортировкой никак не обойтись..варианты с дополнительными действиями в виде скрытых столбцов, формул и т.д. не подходят..т.к. табелей много..их присылают 2 раза в месяц и в ручную производить какие-либо действия очень долго..поэтому прошу Помощи в написании макроса!

Заранее Благодарю всех откликнувшихся!
 
В допстолбце объединить данные и сортировать по нему.
=A2&B2&C2
 
XattoriXanzo, можно как-то так:
Код
Sub sortMerged()
    Dim lastCell As Range, sortRn As Range, movingRn As Range, _
        FirstEntry As Range, surnames As Object, insertRn As Range
    ' Найти в первых столбцах (на разных листах - разные буквы) шапку 1-2-3 и спуститься на 1 элемент
    Set FirstEntry = [A:D].Find(What:="1", LookAt:=xlWhole).Offset(1, 0)
    ' Найти в столбце из FirstEntry последний элемент (подъем "снизу" + кол-во объединенных ячеек)
    Set lastCell = Cells(Rows.Count, FirstEntry.Column).End(xlUp).MergeArea
    ' Запомнить все между FirstEntry и lastCell
    Set sortRn = Range(FirstEntry, lastCell(lastCell.Count))
    ' Словарь для сортировки - фамилии сотрудников. Т.к. дублируются - для уникальности ключа в конце добавляем табельный номер
    ' Ключи вида: Иванов-1;Сидоров-10
    ' Содержимое - ячейки с данными сотрудника
    Set surnames = CreateObject("Scripting.Dictionary")
    ' Идем по всем записям в столбце табельных номеров
    For i = 1 To sortRn.Rows.Count
        ' Для каждого сотрудника запись имеет объединенные ячейки, в обратном случае пропускаем
        If Not sortRn(i).MergeArea Is Nothing Then
            surnames.Add Key:=sortRn(i).MergeArea.Cells(1, 1).Offset(0, 1).Value & "-" & sortRn(i).MergeArea.Cells(1, 1).Value, _
                         Item:= _
                                sortRn(i)(1) _
                                    .Offset(0, 1) _
                                    .Resize( _
                                            sortRn(i).MergeArea.Rows.Count, _
                                            Cells.SpecialCells(xlCellTypeLastCell).Column - sortRn(i).Column _
                                            )
            ' Объединенные ячейки сотрудника добавлены в словарь, строка следующей записи - через кол-во объединенных ячеек
            i = i + sortRn(i).MergeArea.Rows.Count - 1
        End If
    Next i
    
    ' Сортировка словаря по Chip Pearson'у, по ключам словаря, см.файл-пример
    SortDictionary Dict:=surnames, SortByKey:=True
    
    
    ' Перестановка отсортированных диапазонов, от последнего к первому
    For i = surnames.Count - 1 To 0 Step -1
        ' Перетаскиваемый диапазон
        Set movingRn = surnames.Items()(i)
        ' Диапазон куда вставлять (под шапку 1-2-3-4...)
        Set insertRn = FirstEntry.Offset(0, 1).Resize(movingRn.Rows.Count, movingRn.Columns.Count)
        ' Вырезать
        movingRn.Cut
        ' Вставить
        insertRn.Insert Shift:=xlDown
    Next i
End Sub

Т.к. у Вас не фиксированы столбцы с данными, приходится извращаться с выбираемым диапазоном. Могут быть накладки, хотя оба приложенных примера отрабатывает.
In GoTo we trust
 
Цитата
tolstak написал:
Т.к. у Вас не фиксированы столбцы с данными, приходится извращаться с выбираемым диапазоном. Могут быть накладки, хотя оба приложенных примера отрабатывает.
Ошибки вылетают..перепробовал что мог..не помогло((
Цитата
Compile error:
User-defined type not defined
и вот эти слова выделены...
Код
Public Sub SortDictionary(Dict As Scripting.Dictionary, _
    SortByKey As Boolean, _
    Optional Descending As Boolean = False, _
    Optional CompareMode As VbCompareMethod = vbTextCompare)
 
XattoriXanzo, пардон, увлекся оптимизацией, не оттестировал.
В решении используется Reference на Microsoft Scripting Runtime, нужно ее включить в окне с макросами. Tools -> References ->Найти и добавить Microsoft Scripting Runtime
В приложении включил.
In GoTo we trust
 
Код
Sub SortTabel()
Dim i&, y&, mx&, fir&, lst&, f&, x, x1&, str&, cl&, arr As Range, firC&
Application.ScreenUpdating = 0
With Application.WorksheetFunction
firC = ActiveSheet.UsedRange.Find("¹", , xlValues, xlWhole).Column
If firC - 2 = 0 Then GoTo 0
If firC - 2 > 0 Then
    For i = firC - 2 To 1 Step -1
        Columns(1).Delete Shift:=xlToLeft
    Next
Else
    For i = 2 - firC To 1
        Columns(1).Insert Shift:=xlToRight
    Next
End If
0:
mx = .Max(Columns(2))
fir = Columns(2).Find(1, , xlValues, xlWhole).row + 1
lst = mx * 4 + fir
Set arr = Range(Cells(fir, 3), Cells(lst, 3))
For f = fir To lst
    If Cells(f, 2) > 0 Then
        Cells(f, 1) = .CountIf(arr, "<=" & Cells(f, 3))
    Else
        Cells(f, 1) = Empty
    End If
Next
ReDim t(1 To lst, 1 To 30)
For i = 1 To mx
    x = Application.evaluate("SMALL(" & arr.Offset(, -2).Address & "," & i & ")")
    x1 = Columns(1).Find(x, , xlValues, xlWhole).row
    For str = 1 To 4
    y = y + 1
        For cl = 1 To 30
            t(y, cl) = Cells(x1 + str - 1, cl + 2)
        Next cl
    Next str
Next
ActiveSheet.Cells(fir, 3).Resize(mx * 4, 30) = t
End With
Columns(1).Clear
Application.ScreenUpdating = 1
End Sub
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
Да, всё заработало! Благодарю!!!
Но тут начал тестить на всех табелях, которые у меня есть, о сюда не прикреплял..и вылезает ошибка..
Цитата
Run-time error 457:
This key is already associated with an element of this collection
Как я понял это из-за того, что в других табелях иногда появляются люди одинаковые (даже по табельному номеру), которые были занесены макросом в какую-то библиотеку из предыдущих табелей..
 
XattoriXanzo, хм, получается, что один и тот же сотрудник с одинаковым табельным номером дважды появляется в одном отчете. Если макрос применяете к 1 отчету - не должен из других листов ничего брать.
Вероятно, имеет смысл добавить еще номер строк с данными сотрудника в конец ключа:
Код
If Not sortRn(i).MergeArea Is Nothing Then
            surnames.Add Key:=sortRn(i).MergeArea.Cells(1, 1).Offset(0, 1).Value & "-" & sortRn(i).MergeArea.Cells(1, 1).Value & "-" & i, _
                         Item:= _
In GoTo we trust
 
tolstak, я ошибся в определении проблемы выше..сейчас локализовал её..прикрепляю файл..добавил ещё один табель..в нём вылетает ошибка, про которую выше писал..в самом низу где идёт реквизит "Ответственное лицо..." само это слово в изначальном примере на одном месте, а есть ещё табеля где эти слова сдвинуты..и из-за их положения и вылетает ошибка..можно ли это поправить? И тогда будет то что надо!)
 
XattoriXanzo, есть два варианта - дальше пытаться подобрать вариант под все возможные случаи, или просить пользователя помочь :)
Второй путь реализуется так:
Код
    ' Найти в первых столбцах (на разных листах - разные буквы) шапку 1-2-3 и спуститься на 1 элемент
    Set FirstEntry = [A:D].Find(What:="1", LookAt:=xlWhole).Offset(1, 0)
    ' Найти в столбце из FirstEntry последний элемент (подъем "снизу" + кол-во объединенных ячеек)
    Set lastCell = Cells(Rows.Count, FirstEntry.Column).End(xlUp).MergeArea
    ' Запомнить все между FirstEntry и lastCell
    Set sortRn = Range(FirstEntry, lastCell(lastCell.Count))
    ' Выделяем выбранный диапазон для наглядности
    sortRn.Select
    ' Спрашиваем пользователя - правильный ли диапазон выбрал макрос.
    Set sortRn = Application.InputBox(Prompt:="Проверьте корректность диапазона с данными", Default:=sortRn.Address, Type:=8)
    

макрос так же как и раньше выбирает диапазон, а пользователю выдает его для проверки. Если все ок - подтверждаем, если нет - вводим корректный.
In GoTo we trust
 
tolstak, Последний вариант хороший..! Благодарю Вас за помощь! Очень выручили!))
Страницы: 1
Наверх