Author Topic: Export all DataRecordsets to Excel  (Read 1362 times)

0 Members and 1 Guest are viewing this topic.

Thomas Winkel

  • Full Member
  • ***
  • Posts: 194
Export all DataRecordsets to Excel
« on: February 14, 2017, 11:19:03 AM »
Hi,

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

Regards,
Thomas

Code: [Select]
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
« Last Edit: February 14, 2017, 11:25:26 AM by Thomas Winkel »