Error in Macro to export multiple tables to Multiple Excel Tabs

[mrthomasshelby]

Hello,

I have 5 tables in my QV app attached and I'm trying to export these 5 tables to 5 different tabs in an excel file. I have used this nice macro that I found here. But the macro doesn't run and I get a popup of the macro module instead as below:

Can someone help me understand the mistake that I'm making here? I'm attaching the sample app for your reference. Thanks in advance!

tamilarasu‌ jagan‌

[olivierrobin]

hello

the code for

copyObjectsToExcelSheet is missing

I think you didn't copy all the code for the macro to work

[Frank_Hartmann · Accepted solution]

Try this:

you will only have to adapt the path of excel export in line 39:

sub exportToExcel
timestamp = date()
'// Array for export definitions
Dim aryExport(4,3)




aryExport(0,0) = "CH391"
aryExport(0,1) = "T1"
aryExport(0,2) = "A1"
aryExport(0,3) = "data"


aryExport(1,0) = "CH392"
aryExport(1,1) = "T2"
aryExport(1,2) = "A1"
aryExport(1,3) = "data"


aryExport(2,0) = "CH393"
aryExport(2,1) = "T3"
aryExport(2,2) = "A1"
aryExport(2,3) = "data"


aryExport(3,0) = "CH394"
aryExport(3,1) = "T4"
aryExport(3,2) = "A1"
aryExport(3,3) = "data"


aryExport(4,0) = "CH395"
aryExport(4,1) = "T5"
aryExport(4,2) = "A1"
aryExport(4,3) = "data"
Dim objExcelWorkbook 'as Excel.Workbook
Set objExcelWorkbook = copyObjectsToExcelSheet(ActiveDocument, aryExport)
filePath = "C:\Users\Admin\Desktop\TEST "&"-"&timestamp&".xlsx"
objExcelWorkbook.SaveAs filePath
objExcelWorkbook.Close
objExcelDoc.Quit
end sub




Private Function copyObjectsToExcelSheet(qvDoc, aryExportDefinition) 'as Excel.Workbook
Dim i 'as Integer
Dim objExcelApp 'as Excel.Application
Dim objExcelDoc 'as Excel.Workbook


Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = hide 'false if you want to hide Excel
objExcelApp.DisplayAlerts = false

Set objExcelDoc = objExcelApp.Workbooks.Add


Dim strSourceObject
Dim qvObjectId 'as String
Dim sheetName
Dim sheetRange
Dim pasteMode
Dim objSource
Dim objCurrentSheet
Dim objExcelSheet






for i = 0 to UBOUND(aryExportDefinition)


'// Get the properties of the exportDefinition array
qvObjectId = aryExportDefinition(i,0)
sheetName = aryExportDefinition(i,1)
sheetRange = aryExportDefinition(i,2)
pasteMode = aryExportDefinition(i,3)

Set objExcelSheet = Excel_GetSheetByName(objExcelDoc, sheetName)
if (objExcelSheet is nothing) then
Set objExcelSheet = Excel_AddSheet(objExcelApp, sheetName)
if (objExcelSheet is nothing) then
msgbox("No sheet could be created, this should not occur!!!")
end if
end if

    objExcelSheet.Select           


set objSource = qvDoc.GetSheetObject(qvObjectId)
Call objSource.GetSheet().Activate()
objSource.Maximize
qvDoc.GetApplication.WaitForIdle


if (not objSource is nothing) then

if (pasteMode = "image") then
Call objSource.CopyBitmapToClipboard()
else
Call objSource.CopyTableToClipboard(true) '// default & fallback
end if

Set objCurrentSheet = objExcelDoc.Sheets(sheetName)
objExcelDoc.Sheets(sheetName).Range(sheetRange).Select
objExcelDoc.Sheets(sheetName).Paste

if (pasteMode <> "image") then
With objExcelApp.Selection
            .WrapText = False
            .ShrinkToFit = False
End With                    
end if       

objCurrentSheet.Range("A1").Select   
end if




next   


Call Excel_DeleteBlankSheets(objExcelDoc)


'// Finally select the first sheet
objExcelDoc.Sheets(1).Select


'// Return value
Set copyObjectsToExcelSheet = objExcelDoc


end function
'// ________________________________________________________________






'// ****************************************************************
'// Internal function for getting the Excel sheet by sheetName
'// ****************************************************************
Private Function Excel_GetSheetByName(ByRef objExcelDoc, sheetName) 'as Excel.Sheet


For Each ws In objExcelDoc.Worksheets
If (trim(ws.Name) = Excel_GetSafeSheetName(sheetName)) then
Set Excel_GetSheetByName = ws
exit function
End If
Next


'// default return value
Set Excel_GetSheetByName = nothing

End Function
'// ________________________________________________________________




Private Function Excel_GetSafeSheetName(sheetName)


'// can be max 31 characters long
retVal = trim(left(sheetName, 31))

Excel_GetSafeSheetName = retVal
End Function






'// ****************************************************************
'// Internal function for adding a new sheet
'// ****************************************************************
Private Function Excel_AddSheet(objExcelApplication, sheetName) ' as Excel.Sheet


'// add a sheet to the last position
objExcelApplication.Sheets.Add , objExcelApplication.Sheets(objExcelApplication.Sheets.Count)

Dim objNewSheet
Set objNewSheet = objExcelApplication.Sheets(objExcelApplication.Sheets.Count)
objNewSheet.Name = left(sheetName,31)

'// return the newly created sheet
Set Excel_AddSheet = objNewSheet


End function
'// ________________________________________________________________






'// ****************************************************************
'// Delete all empty sheets
'// ****************************************************************
Private Sub Excel_DeleteBlankSheets(ByRef objExcelDoc)


For Each ws In objExcelDoc.Worksheets
If (not HasOtherObjects(ws)) then
If objExcelDoc.Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
On Error Resume Next
Call ws.Delete()
End If
End If
Next

End Sub
'// ________________________________________________________________








'// ****************************************************************
'// Helper function to determine if there are other objects placed
'// on the sheet ...
'// ****************************************************************
Public Function HasOtherObjects(ByRef objSheet) 'As Boolean
    Dim c
    If (objSheet.ChartObjects.Count > 0) Then
    HasOtherObjects = true
    Exit function
    End If
    If (objSheet.Pictures.Count > 0) Then
    HasOtherObjects = true
    Exit function
    End If
    If (objSheet.Shapes.Count > 0) Then
    HasOtherObjects = true
    Exit function
    End If


    HasOtherObjects = false
End Function
'//__________________________________________________________________

hope this helps

[mrthomasshelby]

Hi Frank! Thanks for your time. I have tried this code in my macro but still getting the same error. Can I trouble you to try running the macro in the attached qvw and see if it works for you? Thanks a lot!

[Frank_Hartmann]

For me it works fine!

[olivierrobin]

ypu may have to change this line

filePath = "C:\Users\Admin\Desktop\TEST "&"-"&timestamp&".xlsx" 

according to your installation

[mrthomasshelby]

Thanks Frank. This works now for some weird reason it wasn't before. Appreciate your time and efforts!