Copy and Paste Number Formatting Only

I've got this to work for copying a single cell and pasting over a selection of cells:

Dim format As String

Sub CopyNumberFormat()
format = ActiveCell.NumberFormat
End Sub

Sub PasteNumberFormat()
Selection.NumberFormat = format
End Sub

Then I tried changing

format = ActiveCell.NumberFormat

to

format = Selection.NumberFormat

and got an error code.

Anybody know how to copy or store number formats over a selection?

I'm trying to just copy the number formatting from a row to new rows below it.
I don't need the values or colors and most the time there is data already in the rows below so I'd like to not have it messed with.

Hi tricky,

I'm trying to just copy the number formatting from a row to new rows below it.

Try the following. It copies number formats and formulas. If any of your source rows have formulas you don't want to replicate, the formulas can be removed from the destination rows.

Sub CopyRowNumberFormatForOneRow()

  Dim iSourceRow As Long
  
  'Get the Source Row
  iSourceRow = ActiveCell.Row

  'Copy the Entire Row
  Rows(iSourceRow).Copy
  
  'Paste the number formats to the next row
  With Rows(iSourceRow + 1)
     .PasteSpecial xlPasteFormulasAndNumberFormats
  End With
  
  
  'Clear the Clipboard buffer
  Application.CutCopyMode = False

End Sub


Sub CopyRowNumberFormatForSeveralRows(iRowCountToFormat As Long)

  Dim iDestinationStartRow As Long
  Dim iDestinationEndRow As Long
  Dim iSourceRow As Long
  Dim sRange As String
  
  'Get the Source Row
  iSourceRow = ActiveCell.Row

  'Copy the Entire Row
  Rows(iSourceRow).Copy
  
  'Determine the range of rows needed as a destination
  iDestinationStartRow = iSourceRow + 1
  iDestinationEndRow = iDestinationStartRow + iRowCountToFormat - 1
  sRange = iDestinationStartRow & ":" & iDestinationEndRow
  
  
  'Paste the number formats to the next row
  With Range(sRange)
     .PasteSpecial xlPasteFormulasAndNumberFormats
  End With
  
  
  'Clear the Clipboard buffer
  Application.CutCopyMode = False

End Sub

Sub TestCopyRowNumberFormatForSeveralRows()

  Call CopyRowNumberFormatForSeveralRows(3)

End Sub

Lewis

Maybe :

Public arrNumberFormat() As String
Public Sub CopyNumberFormat()
  Dim i As Long, j As Long
  If TypeName(selection) <> "Range" Then Exit Sub
  ReDim arrNumberFormat(1 To selection.Rows.Count, 1 To selection.Columns.Count)
  Application.ScreenUpdating = False
  For i = 1 To selection.Rows.Count
      For j = 1 To selection.Columns.Count
          arrNumberFormat(i, j) = selection.Cells(i, j).NumberFormat
      Next j
  Next i
  Application.ScreenUpdating = True
End Sub
Public Sub PasteNumberFormat()
  Dim i As Long, j As Long
  If TypeName(selection) <> "Range" Then Exit Sub
  Application.ScreenUpdating = False
  If UBound(arrNumberFormat, 1) = 1 Then
     For j = 1 To Application.Min(selection.Columns.Count, UBound(arrNumberFormat, 2))
         If Len(arrNumberFormat(1, j)) Then selection.Columns(j).Cells.NumberFormat = arrNumberFormat(1, j)
     Next j
  ElseIf UBound(arrNumberFormat, 2) = 1 Then
     For i = 1 To Application.Min(selection.Rows.Count, UBound(arrNumberFormat, 1))
         If Len(arrNumberFormat(i, 1)) Then selection.Rows(i).Cells.NumberFormat = arrNumberFormat(i, 1)
     Next i
  Else
     For i = 1 To Application.Min(selection.Rows.Count, UBound(arrNumberFormat, 1))
         For j = 1 To Application.Min(selection.Columns.Count, UBound(arrNumberFormat, 2))
             If Len(arrNumberFormat(i, j)) Then selection.Cells(i, j).NumberFormat = arrNumberFormat(i, j)
         Next j
     Next i
  End If
  Application.ScreenUpdating = True
End Sub

Thanks to both of you for your time. karedog your code seems to be working good. I think it will do.

You are welcome, and thanks for the reputation points.


Regards