Export all DataRecordsets to Excel

Started by Thomas Winkel, February 14, 2017, 04:19:03 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

Thomas Winkel

Hi,

if you have external data in your document, the following code exports each DataRecordset to Excel.

Regards,
Thomas


Sub exportDataRecordSets()
    Dim drs As Visio.DataRecordset
    Dim dataRowIDs() As Long
    Dim xlsApp As Excel.Application
    Dim xlsWB As Excel.Workbook
    Dim xlsWS As Excel.Worksheet
    Dim arr() As String
    Dim txt As String
    Dim i As Integer
   
    If ActiveDocument.DataRecordsets.Count = 0 Then Exit Sub
   
    Set xlsApp = New Excel.Application
    xlsApp.Visible = False
    Set xlsWB = xlsApp.Workbooks.Add
   
    For Each drs In ActiveDocument.DataRecordsets
        Set xlsWS = xlsWB.Worksheets.Add(After:=xlsWB.Worksheets(xlsWB.Worksheets.Count))
        xlsWS.name = drs.name
       
        txt = ""
        For i = 1 To drs.DataColumns.Count
            txt = txt & drs.DataColumns.item(i).name & ";"
        Next i
        txt = Left(txt, Len(txt) - 1)
        arr = Split(txt, ";")
       
        xlsWS.Range(xlsWS.Cells(1, 1), xlsWS.Cells(1, UBound(arr) + 1)).Value = arr
       
        dataRowIDs = drs.GetDataRowIDs("")
        For i = LBound(dataRowIDs) To UBound(dataRowIDs)
            xlsWS.Range(xlsWS.Cells(i + 2, 1), xlsWS.Cells(i + 2, UBound(arr) + 1)).Value = drs.GetRowData(dataRowIDs(i))
        Next i
       
        xlsWS.ListObjects.Add(xlSrcRange, xlsWS.Range(xlsWS.Cells(1, 1), xlsWS.Cells(i + 1, UBound(arr) + 1)), , xlYes).name = drs.name
        xlsWS.Cells.EntireColumn.AutoFit
    Next drs
   
    xlsWB.Worksheets(1).Delete
    xlsWB.Worksheets(1).Activate
    xlsApp.Visible = True
End Sub