8 Replies Latest reply: Mar 31, 2017 8:50 AM by Laurie Steck RSS

    Exporting multiple objects to multiple Excel sheets

    Laurie Steck

      I tried to implement the code from qlikblog_ExportToMultipleExcelSheets.qvw; and couldn't get it to run. I wound up putting in 14 msgbox commands along the entire code until I could get it working by process of elimination. I was able to get it down to where msgbox "2" was. When I run the macro, it works perfectly if I leave msgbox "2" in the code, and press OK when the box comes up. But when I comment out msgbox "2", the code breaks and the macro fails. It just stops and opens the module window.

       

      Can anyone see a reason why this would be occurring where the msgbox command is? Unfortunately due to confidentiality of data, I cannot attach the file.

       

       

      sub exportToExcel_Variant2

      '// Array for export definitions
      Dim aryExport(5,3)


      aryExport(0,0) = "objRanking"
      aryExport(0,1) = "Ranking-Screening"
      aryExport(0,2) = "A1"
      aryExport(0,3) = "data"

      aryExport(1,0) = "objNomem"
      aryExport(1,1) = "Nomem"
      aryExport(1,2) = "A1"
      aryExport(1,3) = "data"

      aryExport(2,0) = "objNotif"
      aryExport(2,1) = "M6 Notification"
      aryExport(2,2) = "A1"
      aryExport(2,3) = "data"

      aryExport(3,0) = "objFAD"
      aryExport(3,1) = "FAD"
      aryExport(3,2) = "A1"
      aryExport(3,3) = "data"

      aryExport(4,0) = "objRun"
      aryExport(4,1) = "Run History"
      aryExport(4,2) = "A1"
      aryExport(4,3) = "data"

      aryExport(5,0) = "objZJAM"
      aryExport(5,1) = "ZJAM"
      aryExport(5,2) = "A1"
      aryExport(5,3) = "data"

      Dim objExcelWorkbook 'as Excel.Workbook
      Set objExcelWorkbook = copyObjectsToExcelSheet(ActiveDocument, aryExport)


      '// Now either just leave Excel open or do some other stuff here
      '// like saving the excel, some formatting stuff, ...

      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 = true 'false if you want to hide Excel
      objExcelApp.DisplayAlerts = false

      msgbox "2"


      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
      '//__________________________________________________________________