VB Macro to Loop (User-Defined) Field and Export (User-Defined) Chart to Excel and Name Sheets by Field Value

    This is a vbScript macro that uses two variables primarily in the QV application - vfname and vMacroChartId.

     

    The script will loop the field provided as the value in the variable - most likely via input box object in the QV app - and export to Excel the object id provided as the value in the second variable - also most likely via input box in the QV app. Within Excel, this will result in the copied object being pasted into each sheet for the possible values available in the field variable as well as name the sheet with the field value selected at the time of export.

     

    This has potential in various applicable contexts to add much more flexibility to the standard Excel export options within QV currently.

     

    SUB AdHocExport

    confirmation = MSGBOX ("Ad hoc Excel export has been initiated." & vbCrLf & "Do you wish to continue?"& vbCrLf &"",  36, "Export Confirmation")

            IF confirmation = 7 THEN

                EXIT SUB

            END IF

    DIM xlApp

    DIM xlBook

    DIM xlSheet

    DIM strSheetName

    DIM var

    DIM fname

    SET f = ActiveDocument.Variables("vfname")

        fname = f.GetContent.STRING

    SET v = ActiveDocument.Variables("vMacroChartId")

        var = v.GetContent.STRING

    SET xlApp = CREATEOBJECT("Excel.Application")

        xlApp.Visible = TRUE

    SET xlBook = xlApp.Workbooks.Add

    SET xlSheet = xlBook.Worksheets("Sheet1")

        ActiveDocument.Fields(fname).Clear

    SET Doc = ActiveDocument

    SET Field = Doc.Fields(fname).GetPossibleValues

    FOR i=0 to Field.Count-1

        Doc.Fields(fname).Clear

        Doc.FIelds(fname).SELECT Field.Item(i).Text

        Doc.GetApplication.WaitForIdle

        Doc.GetSheetObject(var).CopyTableToClipBoard TRUE

        xlApp.ActiveSheet.Paste

        xlSheet.Cells.EntireColumn.AutoFit

        xlSheet.Cells.EntireRow.AutoFit

        strSheetName = Field.Item(i).Text

        xlApp.ActiveSheet.Name = strSheetName

        IF(i<Field.Count-1)THEN

            IF(i>=2)THEN

                xlApp.ActiveWorkbook.Worksheets.Add

            END IF

            IF(i<2) THEN

            xlApp.Worksheets(xlApp.ActiveSheet.Index +1).SELECT

            END IF

        END IF

    NEXT

    Doc.Fields(fname).Clear

    MSGBOX "Ad hoc Excel export is complete!",64,"Task Completion Notification"

    END SUB