Поиск объединенных ячеек

[danetda]

Добрый день,
подскажите, как в макросе обеспечить поиск объединенных ячеек и снять объединение.
Таблица что-то типа прайса из 8 столбцов и разбита на группы, а названия групп в объединенных ячейках. Товары идут построчно. Мне нужно вытащить название группы и добавить в новый столбец к каждому товару наименование группы. Длина объединенных ячеек в разных группах разная, где на 2 столбца, где на 5, но все объединения идут от 1-го столбца таблицы.

[VictorM]

Sub Макрос1()
'если от первого столбца, то
    [A:A].UnMerge
End Sub

[DDMAX]

Не работает
И мне нужно, чтобы именно со знаком ;

[VictorM]

Не работает

Приведенный макрос отменяет объединение ячеек. И только!
Чтобы что-то еще делать - выложите хоть небольшой пример Вашего файла.

[danetda]

VictorM
Спасибо за решение, у меня работает в 2003
А как найти такую объединенную ячейку, что бы спозиционироваться на ней. Решение искать по пустующей рядом ячейке после [A:A].UnMerge решит данную мою проблему, но на будущее, можно это как-то сделать?

[VictorM]

Вот такой простенький код найдет объединенные ячейки на листе

Sub MCells()
   Application.FindFormat.MergeCells = True
    Cells.Find(What:="", After:=ActiveCell, MatchCase:=False, SearchFormat:=True).Activate
End Sub

[lalike]

А как объединить эти два макроса в один?


у меня есть макрос, который правильно объединяет ячейки (в основном при работе с фильтрами),
у меня есть макрос, который находит объединенные ячейки,
у меня есть файл с более чем 20 000 неправильно объединенными ячейками.
как создать цикл, который бы все эти ячейки правилно объединил.

макросы прилагаются
((((((ПРАВИЛЬНАЯ ГРУППИРОВКА))))))
SUB ReMerge() ' перегруппировать сгруппированную ячейку или сгруппировать ячейки выделенного диапазона с заполнением скрытых ячеек формулами-ссылками на первую ячейку
IF TypeName(Selection) <> "Range" THEN EXIT SUB
IF Selection.Cells.Count <= 1 THEN EXIT SUB
DIM i%, iCell AS Range, ActRng AS Range
DIM ActSh AS Worksheet, TempSh AS Worksheet
DIM lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
DIM lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
IF lLastRow > Selection.Row + Selection.Rows.Count - 1 THEN lLastRow = Selection.Row + Selection.Rows.Count - 1
Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
Application.ScreenUpdating = False: Application.DisplayAlerts = False

Set ActSh = ActiveSheet: Set TempSh = Sheets.Add ' запомнить текущую и создать новую страницу
ActRng.Copy TempSh.Range(ActRng.Address)
ActSh.Activate
Selection.UnMerge
FOR i = 2 TO ActRng.Cells.Count ' заполнить Selection формулами-ссылками на первую ячейку
ActRng(i).Formula = "=" & ActRng(1).Address
ActRng(i).Replace What:="$", Replacement:="", LookAt:=xlPart ' сделать ссылки перемещаемыми
NEXT
TempSh.Range(ActRng.Address).Merge
TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True
END SUB


((((((((((((ПОИСК ОБЪЕДИНЕННЫХ ЯЧЕЕК))))))))))))))


SUB MCells()
Application.FindFormat.MergeCells = True
Cells.Find(What:="", After:=ActiveCell, MatchCase:=False, SearchFormat:=True).Activate
END SUB



(((((ПРИБЛИЗИТЕЛЬНЫЙ ЦИКЛ))))))))))

0 ПОВТОРИТЬ ПОКА НЕ ДОСТИГЛИ КОНЦА ТАБЛИЦЫ
1 ПОИСК ЯЧЕЙКИ
2 ПРИМЕНЕНИЕ МАКРОСА


Я, к сожалению не знаю синтаксиса(

[lalike]

Помогите, пожалуйста?!

[lalike]

Sub m_1()
Dim i As Long
For i = 1 To 10000 ' количество ячеек в моей таблице


Application.FindFormat.MergeCells = True
Cells.Find(What:="", After:=ActiveCell, MatchCase:=False, SearchFormat:=True).Activate


If TypeName(Selection) <> "Range" Then Exit Sub
If Selection.Cells.Count <= 1 Then Exit Sub
Dim i%, iCell As Range, ActRng As Range
Dim ActSh As Worksheet, TempSh As Worksheet
Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set ActSh = ActiveSheet: Set TempSh = Sheets.Add ' запомнить текущую и создать новую страницу
ActRng.Copy TempSh.Range(ActRng.Address)
ActSh.Activate
Selection.UnMerge
For i = 2 To ActRng.Cells.Count ' заполнить Selection формулами-ссылками на первую ячейку
ActRng(i).Formula = "=" & ActRng(1).Address
ActRng(i).Replace What:="$", Replacement:="", LookAt:=xlPart ' сделать ссылки перемещаемыми
Next
TempSh.Range(ActRng.Address).Merge
TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True

Next i
End Sub



может так??

[lalike]

Sub cikl()
Dim x As Long
Dim i%, iCell As Range, ActRng As Range
Dim ActSh As Worksheet, TempSh As Worksheet
Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1

For x = 1 To 100
Application.FindFormat.MergeCells = True
Cells.Find(What:="", After:=ActiveCell, MatchCase:=False, SearchFormat:=True).Activate
If TypeName(Selection) <> "Range" Then Exit Sub
If Selection.Cells.Count <= 1 Then Exit Sub

If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
Application.ScreenUpdating = False: Application.DisplayAlerts = False

Set ActSh = ActiveSheet: Set TempSh = Sheets.Add ' ????????? ??????? ? ??????? ????? ????????
ActRng.Copy TempSh.Range(ActRng.Address)
ActSh.Activate
Selection.UnMerge
For i = 2 To ActRng.Cells.Count ' ????????? Selection ?????????-???????? ?? ?????? ??????
ActRng(i).Formula = "=" & ActRng(1).Address
ActRng(i).Replace What:="$", Replacement:="", LookAt:=xlPart ' ??????? ?????? ?????????????
Next
TempSh.Range(ActRng.Address).Merge
TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Next x
End Sub


или так?