extract xlm.vba

Sub rangeexport()


    Dim wdApp As Word.Application
    Dim doc As Word.Document
    Set wdApp = CreateObject("Word.application")
    'Set doc = wdApp.Documents.Add()
    
      
    Dim element As Excel.name
    For Each element In ActiveWorkbook.Names
        Set doc = wdApp.Documents.Add()
        doc.Range.InsertAfter "Reference name: "
        doc.Range.InsertAfter element.name & vbCrLf
        doc.Range.InsertAfter "Refers to: "
        doc.Range.InsertAfter element.RefersTo & vbCrLf
        doc.Range.InsertAfter "Value: "
        doc.Range.InsertAfter element.Value & vbCrLf
        doc.Range.InsertAfter "Category: "
        On Error Resume Next
        doc.Range.InsertAfter element.Category
        On Error GoTo 0
        doc.Range.InsertAfter vbCrLf
        
        'On Error Resume Next
        If Not HasReferToRange(element) Then
            doc.Range.InsertAfter "Invalid range, or not a range"
        ElseIf Not element.RefersToRange.Worksheet.name = $macosheetname Then
            doc.Range.InsertAfter "Not in " + $macrosheetname
        ElseIf element.RefersToRange.Columns.Count = 1 And element.RefersToRange.Rows.Count = 1 And element.RefersToRange.Cells(1, 1).Text = element.name Then
            On Error GoTo 0
            doc.Range.InsertAfter "Formula code: "
            doc.Range.InsertAfter vbCrLf
            Dim col As Long
            col = column_in_range(element.RefersToRange.Parent.Cells, element.RefersToRange)
            Dim rowi As Long
            rowi = row_in_range(element.RefersToRange.Parent.Cells, element.RefersToRange)
            Dim i As Long
            For i = rowi To rowi + 100
                Dim c As Excel.Range
                Dim p As Object
                Set p = element.RefersToRange.Worksheet
                Set c = p.Cells(i, col)
                doc.Range.InsertAfter c.Formula
                doc.Range.InsertAfter vbCrLf
                If c.Formula = "=RETURN()" Then
                    Exit For
                End If
            Next i
        ElseIf element.RefersToRange.Columns.Count = 1 Then
            doc.Range.InsertAfter "Formula: "
                doc.Range.InsertAfter vbCrLf
            Dim row As Excel.Range
            For Each row In element.RefersToRange.Rows
                doc.Range.InsertAfter row.Formula
                doc.Range.InsertAfter vbCrLf
            Next row
        Else
            doc.Range.InsertAfter "Too many columns"
        End If
        On Error GoTo 0
        doc.Range.InsertAfter vbCrLf
        
        'doc.Range.InsertAfter vbCrLf
        'doc.Range.InsertAfter vbCrLf
        'doc.Range.InsertAfter vbCrLf
        On Error Resume Next
        doc.SaveAs2 filename:="C:\Users\"+$username+"\Desktop\output\" + element.name + ".docx"
        On Error GoTo 0
    Next element
    
    wdApp.ActiveWindow.Visible = True
    wdApp.Activate

End Sub

Function column_in_range(r As Range, c As Range) As Long
  column_in_range = c.column - (r.Cells(1, 1).column - 1)
End Function

Function row_in_range(r As Range, c As Range) As Long
  row_in_range = c.row - (r.Cells(1, 1).row - 1)
End Function

Function HasReferToRange(element As Excel.name) As Boolean
    On Error GoTo Done
    Dim test As Excel.Range
    Set test = element.RefersToRange
    HasReferToRange = True
    On Error GoTo 0
    Exit Function
Done:
    On Error GoTo 0
    HasReferToRange = False
End Function