Страницы: 1
RSS
Объединение идентичных данных в один столбец (ФИО), Объединение идентичных данных (ФИО) в один столбец в целях исключения повторений
 
Добрый день! Столкнулся с определенной трудностью при решении задачи объединения на паре.

Задача заключается в том, чтобы объединять в один столбец повторяющиеся ФИО. В принципе это можно сделать вручную, если бы таблица была небольшой. Но речь идет о таблице, где больше 10 000 столбцов. Прикреплю образец для примера)

Большая просьба помочь, если есть кто знает. Заранее благодарю  :)  
 
Добрый день! У Вас в примере и так все ФИО в одном столбце... покажите в примере результат (то что нужно в итоге получить)
 
Возможно я неправильно сформулировал вопрос. Прикрепляю пример (до) и результат (то, что должно получиться)
 
Сводной таблицей

Добавил с объединением файл _2
Изменено: _Boroda_ - 17.05.2022 10:50:50
Скажи мне, кудесник, любимец ба’гов...
 
Цитата
Цитата
Сводной таблицей

Добавил с объединением файл _2
Не совсем то, что нужно)
Да, то что Вы сделали объединило ФИО, но установленная фильтрация в таблице (Пример_.xlsx ) при этом нарушена. Нужно именно в той последовательности объединять в один столбец повторяющиеся ФИО))
Изменено: Иван Смирнов - 17.05.2022 11:05:35
 
Ну так добавьте счетчик
Скажи мне, кудесник, любимец ба’гов...
 
Иван Смирнов, почему Иванов Иван Иванович не объединён в строке 10 с предыдущими строками (8, 9)?

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Код
Sub myMerge()
    ActiveSheet.Copy
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Dim rn As Range
        Set rn = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp).Cells(1, 3))
    End With
            
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
            
    'SortRange rn
    MergeRange rn
    
    Application.Calculation = Application_Calculation
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
        
Private Sub MergeRange(rn As Range)
    Dim y1 As Long
    Dim y2 As Long
    Dim arr As Variant
    arr = rn
    
    Application.DisplayAlerts = False
    For y1 = 2 To UBound(arr, 1)
        y2 = y1
        Do
            If y2 = UBound(arr, 1) Then Exit Do
            If arr(y2 + 1, 2) <> arr(y1, 2) Then Exit Do
            y2 = y2 + 1
            DoEvents
        Loop
        If y1 <> y2 Then
            rn.Range(Cells(y1, 1), Cells(y2, 1)).Merge
            rn.Range(Cells(y1, 2), Cells(y2, 2)).Merge
            y1 = y2
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub SortRange(rn As Range)
    With rn.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rn.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=rn.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rn
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

 
Вангую. В ближайшее время появятся темы от Иван Смирнов с вопросами типа "Получить данные из объединённых ячеек", "Высота строк объединённых ячеек", "Протянуть формулу в объединённых ячейках" и т.п.
Таких тем много на этом форуме. В итоге самая лучшая рекомендация: объединённые ячейки - зло!
 
Цитата
написал:
Иван Смирнов, почему Иванов Иван Иванович не объединён в строке 10 с предыдущими строками (8, 9)?
Пропустил) Не увидел)
 
tolikt, Эх, #студент1курса  :)  
 
Цитата
написал:
Вангую. В ближайшее время появятся темы от  Иван Смирнов  с вопросами типа "Получить данные из объединённых ячеек", "Высота строк объединённых ячеек", "Протянуть формулу в объединённых ячейках" и т.п.
Таких тем много на этом форуме. В итоге самая лучшая рекомендация: объединённые ячейки - зло!
😄
Страницы: 1
Наверх