Get selection formatting

Here is a nice and handy script to get all the main format for a range selection, that can be applied afterwards to same range (as template):

Public Sub sFormatGet()
    Call fFormatGet(Selection)
End Sub

Public Function fRangeR1C1(ByVal oXlRng As Excel.Range, _
                           Optional ByVal oXlRef As Excel.Range = Nothing) As String
    Dim lgC As Long
    Dim lgR As Long
    Dim strRngR1C1 As String

    If oXlRef Is Nothing Then
        Set oXlRef = ActiveSheet.Cells(1, 1)
    End If

    lgR = oXlRng.Row
    lgC = oXlRng.Column

    fRangeR1C1 = strRngR1C1
End Function

Public Function fFormatGet(ByRef oXlRng As Excel.Range, _
                           Optional ByVal ReferenceStyle As XlReferenceStyle = xlA1) As Boolean
    If oXlRng Is Nothing Then
        Set oXlRng = Selection.Cells
    End If

    Dim oXlCell As Excel.Range
    Dim lgBorder As Long
    Dim iFileOut As Integer
    Dim bFormat As Boolean
    Dim bRange As Boolean
    Dim strRange As String

    Close
    iFileOut = VBA.FreeFile()
    Open VBA.Environ$("UserProfile") & "\Documents\" & "#Format.bas" For Output As #iFileOut
    
    Print #iFileOut, "Private Sub sFormatSet(ByVal xlWsh As Excel.Worksheet)"
    Print #iFileOut, "  'Dim oXlCell As Excel.Range"
    Print #iFileOut, ""
    Print #iFileOut, "  With xlWsh"
    
    For Each oXlCell In oXlRng.Cells
        bFormat = False
        bRange = False
        If oXlCell.MergeCells Then
            ' only if cell is the left-top most cell in merge area,...
            If oXlCell.MergeArea.Cells(1, 1).Address = oXlCell.Address Then
                bFormat = True
                oXlCell.MergeArea.Merge
                bRange = True
                strRange = ".Range(""" & oXlCell.MergeArea.Address & """)"
                
                'If ReferenceStyle = xlA1 Then
                '    strRange = .Formula
                'Else
                '    strRange = fRangeR1C1(oXlCell.MergeArea)
                'End If
            End If
        Else
            bFormat = True
            strRange = ".Cells(" & oXlCell.Row & ", " & oXlCell.Column & ")"
            
            'If ReferenceStyle = xlA1 Then
            '    strRange = .Formula
            'Else
            '    strRange = fRangeR1C1(oXlCell)
            'End If
        End If
        
        If bFormat Then
        Print #iFileOut, "    With " & strRange
        Print #iFileOut, "      .Merge"
        If oXlCell.Formula <> vbNullString Then
            'If ReferenceStyle = xlA1 Then
                Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.Formula, """", """""")
            'Else
            '    Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.FormulaR1C1, """", """""")
            'End If
        End If
        
        With oXlCell
            If .IndentLevel <> 0 Then
                Print #iFileOut, "    .IndentLevel = " & .IndentLevel
            End If
            
            With .Font
                Print #iFileOut, "      With .Font"
                Print #iFileOut, "        .Name = """ & .Name & """"
                Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Size = " & .Size
                If .Bold Then Print #iFileOut, "        .Bold = " & .Bold
                If .Italic Then Print #iFileOut, "        .Italic = " & .Italic
                If .Underline <> xlNone Then Print #iFileOut, "        .Underline = " & VBA.CBool(.Underline)
                If .Strikethrough Then Print #iFileOut, "        .Strikethrough = " & VBA.CBool(.Strikethrough)
                If .Subscript Then Print #iFileOut, "        .Subscript = " & VBA.CBool(.Subscript)
                If .Superscript Then Print #iFileOut, "        .Superscript = " & VBA.CBool(.Superscript)
                Print #iFileOut, "      End With"
            End With
            If .Hyperlinks.Count > 0 Then
                With .Hyperlinks(1)
                    Print #iFileOut, "    .Hyperlinks.Add(" & _
                        "               Anchor:=" & oXlCell & ", " & _
                        VBA.IIf(.Address = vbNullString, "", "               Address:=" & .Address & ", ") & _
                        VBA.IIf(.SubAddress = vbNullString, "", "               SubAddress:=" & .SubAddress & ", ") & _
                        VBA.IIf(.ScreenTip = vbNullString, "", "               ScreenTip:=" & .ScreenTip & ", ") & _
                        VBA.IIf(.TextToDisplay = vbNullString, "", "               TextToDisplay:=" & .TextToDisplay & ", ") & _
                        ")"
                End With
            End If
            Print #iFileOut, "      .NumberFormat = """ & .NumberFormat & """"
            Print #iFileOut, "      .Orientation = " & .Orientation
            Print #iFileOut, "      .ShrinkToFit = " & .ShrinkToFit
            
            With .Interior
                Print #iFileOut, "      With .Interior"
                If .ColorIndex <> xlNone Then Print #iFileOut, "        .ColorIndex = " & .ColorIndex
                If .PatternColor <> 0 Then Print #iFileOut, "        .PatternColor = " & .PatternColor
                If .Pattern <> xlNone Then Print #iFileOut, "        .Pattern = " & .Pattern
                Print #iFileOut, "      End With"
            End With
        End With
        
        For lgBorder = xlEdgeLeft To xlEdgeRight
            With oXlCell.Borders(lgBorder)
                Print #iFileOut, "      With .Borders(" & lgBorder & ")"
                Print #iFileOut, "        .LineStyle = " & .LineStyle
                'Print #iFileOut, "        .ThemeColor = " & .ThemeColor
                If .TintAndShade <> 0 Then Print #iFileOut, "        .TintAndShade = " & .TintAndShade
                If .Color <> 0 Then Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Weight = " & .Weight
                Print #iFileOut, "      End With"
            End With
        Next lgBorder
        Print #iFileOut, "    End With"
        Print #iFileOut, ""
        End If
    Next oXlCell
    
    Print #iFileOut, "  End With"
    Print #iFileOut, "End Sub"
    Close #iFileOut
End Function