vba to paste height and width of selected cell

[davers5]

I'd like to create a shortcut key to paste the row height and column width of a copied cell. The column width part is easy because you can get that from paste special but the row height you can't get from there. My question boils down to this: how do I get the row height (or other properties for that matter) from a cell that has already been copied?

Just to be more clear:
A user selects cell a1 which has a row height of 15 and presses ctrl-c to copy the cell. I then want to be able to click a button that will give any other cell a height of 15.

Thanks!

Dave

 

[ILv2Xlr8]

The workaround is very limited to a specific use.

I would have thought you can assign the rows of one sheet to a variable, and then set the rows of a another sheet equal to the RowHeight of the selected rows.

    Dim myrow As Variant
    Sheets("FROM").Select
    myrow = Columns("A:A").Select
    Sheets("TO").Select
    Rows(Columns("A:A").Select) = Rows(myrow).RowHeight
End Sub

I have very limited knowledge with vb in excel, but I've always been impressed with the knowledgable people on this message board; so perhaps one of the uber users here could explain why this code does not work, or perhaps inspire other possible ways to do this task.

 

[ILv2Xlr8]

However, looping through all the rows may also work as someone posted elsewhere:

Private Sub CopyRowHeigths(TargetRange As Range, SourceRange As Range)
Dim r As Long
    With SourceRange
        For r = 1 To .Rows.Count
            TargetRange.Rows(r).RowHeight = .Rows(r).RowHeight
        Next r
    End With
End Sub

So somehow this should be able to work...

 

[Greg Truby]

OK - if we're actually gonna do this, let's do it up halfway right...

back in a bit...

 

[Greg Truby]

This should provide a reasonably useful tool under most applications.

'// No built-in "copy height" function in PasteSpecial like
'// there is for copying widths.
'// This code allows for the source range to have multiple cells, like
'// the built-in copy width function.  Cycles through source, so if
'// source has three rows and target nine, the heights follow
'// the pattern of a,b,c,a,b,c,a,b,c.

'// Greg Truby, November 2006

Option Explicit
'// these variable names are long; but the suffix should avoid conflicts
'// with other variable names.
Public g_rngSource_copyrows As Range
Public g_rngTarget_copyrows As Range

Sub SetSourceToSelection()
'// for interactive use
    If TypeName(Selection) = "Range" Then Set g_rngSource_copyrows = Selection
    If Not g_rngTarget_copyrows Is Nothing Then CopyRowHeights
End Sub

Sub SetTargetToSelection()
'// for interactive use
    If TypeName(Selection) = "Range" Then Set g_rngTarget_copyrows = Selection
    If Not g_rngSource_copyrows Is Nothing Then CopyRowHeights
End Sub

Sub CallFromCode()
'// how to use in VBA
    Set g_rngSource_copyrows = Sheets(2).Range("A1:A2")
    Set g_rngTarget_copyrows = Sheets(1).Range("A1:A12")
    CopyRowHeights
End Sub

Private Sub CopyRowHeights()

    Dim lngRow As Long
    
    If g_rngSource_copyrows Is Nothing _
    And g_rngTarget_copyrows Is Nothing Then GoTo ErrorMsg

    If g_rngSource_copyrows Is Nothing Then
        If vbNo = MsgBox("No source range set, use current selection?", _
                  vbQuestion + vbYesNo, "Source=Current") Then
            GoTo ErrorMsg                                           ' |--¿goto?-->
        End If
        If TypeName(Selection) <> "Range" Then GoTo ErrorMsg        ' |--¿goto?-->
        Set g_rngSource_copyrows = Selection
    ElseIf g_rngTarget_copyrows Is Nothing Then
        If vbNo = MsgBox("No target range set, use current selection?", _
                  vbQuestion + vbYesNo, "Target=Current") Then
            GoTo ErrorMsg                                           ' |--¿goto?-->
        End If
        If TypeName(Selection) <> "Range" Then GoTo ErrorMsg        ' |--¿goto?-->
        Set g_rngTarget_copyrows = Selection
    End If
    
    For lngRow = 1 To g_rngTarget_copyrows.Rows.Count
        g_rngTarget_copyrows.Cells(lngRow, 1).RowHeight = _
        g_rngSource_copyrows.Cells((lngRow - 1) Mod g_rngSource_copyrows.Rows.Count + 1, 1).RowHeight
    Next lngRow

    Set g_rngSource_copyrows = Nothing
    Set g_rngTarget_copyrows = Nothing
    
    Exit Sub

ErrorMsg:
'"""""""

    MsgBox "Cannot copy row heights.", vbCritical, "Operation Canceled"

End Sub

Note: ideally one would check for any intersections between source and target and require a confirmation from the user if such an intersection exists. I'll leave that to you.

 

[ILv2Xlr8]

I knew this would be a trival task for the subject matter experts we have here on this message board.

One other time saving tweak...

Sub CopyRowHeightsToSheet1()
Application.ScreenUpdating = False
    Set g_rngSource_copyrows = Sheets(2).Range("A1:A65535")
    Set g_rngTarget_copyrows = Sheets(1).Range("A1:A65535")
    CopyRowHeights
Application.ScreenUpdating = True
End Sub

This will eliminate the page updating as the macro works to copy the row heights from sheet to sheet.

 

[Greg Truby]

1. I had not envisioned using this for more than a few dozen rows, but yes, toggling screenupdating would improve performance if many rows are involved. However, generally speaking you want to toggle properties like screenupdating as close to the action as possible, so I would probably code that inside the update itself...

   ... 
   application.screenupdating = false
   For lngRow = 1 To g_rngTarget_copyrows.Rows.Count 
           g_rngTarget_copyrows.Cells(lngRow, 1).RowHeight = _ 
           g_rngSource_copyrows.Cells((lngRow - 1) Mod g_rngSource_copyrows.Rows.Count + 1, 1).RowHeight 
       Next lngRow 
   application.screenupdating = true
   ...

2. Wow. All 65,000+ rows? really? You have that many unique row heights? Most unexpected.