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
может так??
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
может так??