Create Custom Paste Special - Row Heights

[meh2030]

My code thus far is below.

Does anyone know how Microsoft programmatically performs paste special
in Excel? The copy, paste special - column widths is useful, but I
want to perform a paste special - row heights. Below I have included
some syntax for this, but there is one problem - accessing the CutCopy
range.

I have done some searching and have found individuals who have said
that is not possible (posts from 2004); however, there must be some
way to do this, otherwise paste special would not exist at all. This
being said, my hang up is on the syntax line below that states "Set
copyRng = Selection ..." I want the "Selection" to be the CutCopy
range.

So, one idea that I have is to see if there is a way to determine
which sheet has the CutCopyMode activated. (I know that
Application.CutCopyMode will identify from an application point of
view, but I'm wondering if this can be determined from a worksheet
level).

Additionally, I found the code below posted by Bob Phillips; however,
I want to place this row heights macro in my personal.xls file so that
I can use it on any workbook.

Public oldCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not oldCell Is Nothing Then MsgBox oldCell.Address
Set oldCell = Target
End Sub

Any ideas would be greatly appreciated. Thanks in advance.

Sub paste_Row_Heights()

'This sub procedure is intended to act as a copy, paste special
'wherein the row heights are "pasted". Excel has a copy, paste
'special - column widths, but no paste special - row heights.

Dim copyRng As Range
Dim rowRng As Range
Dim numRows As Long
Dim rowHgt() As Double
Dim rowCell As Range
Dim i As Long
Dim j As Long
Dim a

'need to have "copied" a range in order to "paste" the row heights
'at a new location
If Application.CutCopyMode = False Then Exit Sub

'create a range object that storse the range that was copied
'(i.e. the one with the cut/copy border)

Set copyRng = Selection 'want "Selection" to be the "copied" range
'maybe use a sheet selection change/deactivate
event,
'but that doesn't cure a same sheet pasting
Debug.Print copyRng.Address

numRows = copyRng.Rows.Count 'copy the number of rows in the copied
range

'create a new range object that contains only 1 column

Set rowRng = copyRng.Range(Cells(1, 1), Cells(numRows, 1))

ReDim rowHgt(1 To numRows)

'store the row heights of the copied range

i = 0
For Each rowCell In rowRng.Cells
i = i + 1
rowHgt(i) = rowCell.RowHeight
Debug.Print i; ":"; rowHgt(i)
Next

'"paste" the row heights where the active cell is

For j = LBound(rowHgt) To UBound(rowHgt)
Selection.Cells(1, 1).Offset(j - 1, 1).RowHeight = rowHgt(j)
Next

'need to build an error handler to handle a situation where you
'have 10 rows copied and your paste cell is on row 65,530 and
'there are only 7 row location that can be "pasted"
End Sub

 

[Doug Glancy]

Hi there,

My thought is to paste formats to a new, temporary worksheet, count the rows
and save their heights as per your code, then delete the temporary worksheet
and restore the ActiveSheet and Selection and then apply the row heights per
your code. I didn't test it much but it works pasting from one sheet to
another:

Dim wsActiveSheet As Worksheet
Dim rngActiveCell As Range
Dim wsTempSheet As Worksheet
Dim copyRng As Range
Dim rowRng As Range
Dim numRows As Long
Dim rowHgt() As Double
Dim rowCell As Range
Dim i As Long
Dim j As Long
Dim a

Application.ScreenUpdating = False

Set wsActiveSheet = ActiveSheet
Set rngActiveCell = Selection
'need to have "copied" a range in order to "paste" the row heights
'at a new location
If Application.CutCopyMode = False Then Exit Sub

'create a range object that storse the range that was copied
'(i.e. the one with the cut/copy border)

ThisWorkbook.Worksheets.Add
Set wsTempSheet = ActiveSheet
wsTempSheet.Range("A1").PasteSpecial (xlPasteFormats)

Set copyRng = Selection 'want "Selection" to be the "copied" range
'maybe use a sheet selection change/deactivate
event,
'but that doesn't cure a same sheet pasting
Debug.Print copyRng.Address

numRows = copyRng.Rows.Count 'copy the number of rows in the copied Range

'create a new range object that contains only 1 column

Set rowRng = copyRng.Range(Cells(1, 1), Cells(numRows, 1))

ReDim rowHgt(1 To numRows)

'store the row heights of the copied range

i = 0
For Each rowCell In rowRng.Cells
i = i + 1
rowHgt(i) = rowCell.RowHeight
Debug.Print i; ":"; rowHgt(i)
Next

Application.DisplayAlerts = False
wsTempSheet.Delete
Application.DisplayAlerts = True

'"paste" the row heights where the active cell is
wsActiveSheet.Activate
rngActiveCell.Select
For j = LBound(rowHgt) To UBound(rowHgt)
Selection.Cells(1, 1).Offset(j - 1, 1).RowHeight = rowHgt(j)
Next

'need to build an error handler to handle a situation where you
'have 10 rows copied and your paste cell is on row 65,530 and
'there are only 7 row location that can be "pasted"

Application.ScreenUpdating = True

End Sub

hth,

Doug