Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Извлечение уникальных значений из диапазона макросом и копирование их в объединенные ячейки с сохранением исходного форматирования
 
#1
01.07.2020 12:48:25
Доброго всем дня,

В прикрепленном примере "живет" макрос, который копирует данные из диапазона одного листа в другой, сохраняя при этом исходное форматирование..
Мне понадобился макрос, который бы копировал только уникальные значения при наличии онных, и просто копировал бы то что есть, если нет уникальных.
Макрос при копировании также должен сохранять формат исходных данных и сразу реагировать на вносимые в исходный диапазон изменения.
Ячейки в конечном диапазоне объединены.
Благодарю за помощь.
 
 
 
#2
01.07.2020 13:06:47
memo, дд. а моете показать без макроса исходные данные и отдельно желаемый результат?
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
01.07.2020 13:38:33
Mershik, Да, конечно.
Я не договорил/не подумал об одном обстоятельстве - если у одинаковых значений разное форматирование, какое именно из них должен переносить макрос?
Думаю, пусть будет так как в примере - пусть переносит первое по строчке значение.
Ну а если уникальных нет вообще пусть просто копирует диапазон как есть, со всеми форматами.
 
 
 
#4
01.07.2020 15:18:04
memo,
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        If Target.Column = 2 Then
        Application.DisplayAlerts = True
Dim cell As Range
Dim lr As Long
Dim x As Variant
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lr = Worksheets("Calc").Cells(Rows.Count, 2).End(xlUp).Row
x = Target
    Set cell = Worksheets("Sheet2").Range("Z:AG").Find(x, , xlValues)
    If cell Is Nothing Then
        lr = Worksheets("Sheet2").Cells(Rows.Count, 26).End(xlUp).Row + 1
        If lr < 54 Then lr = 54
        Target.Copy
        Worksheets("Sheet2").Cells(lr, 26).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, SkipBlanks:=False
        Worksheets("Sheet2").Range("Z" & lr & ":AG" & lr).Merge
    End If
        End If
    End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#5
01.07.2020 16:32:03
Mershik, Спасибо за код, но возникла одна проблема: в режиме когда в диапазоне B2:B10 все записи разные, и все должно просто копироваться
макрос рассматривает последнюю запись в ячейке B10 (листа CALC), как уникальную и не копирует ее.
Записи в ячейках B2 и B10 похожие, есть только маленькое  различие в тексте (в B2 - PJ-1L, в B10 - PJ). Выделил эти различия
красным.

Выкладываю пример.

Update.
Если убрать один пробел посередине между дробями, то запись из B10 начинает копироваться.

Update #2.
В общем, после долгих экспериментов я пришел к выводу, что если количество пробелов в ячейках после переноса строки не превышает 6, то все работает как надо.
Думаю, этого достаточно. Mershik, благодарю за помощь!.
Изменено: memo - 02.07.2020 11:45:14
 
 
 
Страницы: 1
Наверх