Hi Vijay,
Thanks for all your support.
as per the application shared by you i had modified the Macro code as per my requirement, but i m unable to execute it because of bug in code.
Please can you help me in identify the bug in below code and i had also attach the code.
'Macro Code Starts here
sub Export
Msgbox "Exporting Country Information." & Chr(10) & "Wait until export completes successfully."
'// Array for export definitions
Dim aryExport(3,5)
aryExport(0,0) = "Export"
aryExport(0,1) = "East"
aryExport(0,2) = "A2"
aryExport(0,3) = "data"
aryExport(0,4) = "Region"
aryExport(0,5) = "East"
aryExport(1,0) = "Export"
aryExport(1,1) = "West"
aryExport(1,2) = "A2"
aryExport(1,3) = "data"
aryExport(1,4) = "Region"
aryExport(1,5) = "West"
aryExport(2,0) = "Export"
aryExport(2,1) = "North"
aryExport(2,2) = "A2"
aryExport(2,3) = "data"
aryExport(2,4) = "Region"
aryExport(2,5) = "North"
aryExport(3,0) = "Export"
aryExport(3,1) = "South"
aryExport(3,2) = "A2"
aryExport(3,3) = "data"
aryExport(3,4) = "Region"
aryExport(3,5) = "South"
Dim objExcelWorkbook 'as Excel.Workbook
Set objExcelWorkbook = copyCountryChartsToExcelSheet(ActiveDocument, aryExport)
'// Now either just leave Excel open or do some other stuff here
'// like saving the excel, some formatting stuff, ...
end sub
'// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'// YOU DO NOT NEED TO CHANGE THE CODE BELOW !!!!!!!!!!!!!!!!!!!!!!!
'// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'// ****************************************************************
'// copyObjectsToExcel
'// ~~
'// Parameters:
'// qvDoc - Reference to the QlikView document (normally just use
'// "ActiveDocument", but you can also use copyObjectsToExcel
'// outside of QlikView ...
'// aryExportDefinition - array of settings
'// ~~
'// Version 1.02
'// ~~
'// The aryExportDefinition is used to pass the following properties to
'// copyObjectsToExcelSheet:
'//
'// Index Description
'// ------------------------
'// 0 - Id of the QlikView object to copy from
'// 1 - Name of the sheet (in Excel) where the object should be copied to
'//
'// (If a sheet with the same name already exists no new
'// sheet will be created, instead the existing sheet will
'// be used for pasting the object)
'//
'// Note: the sheetName can be max 31 characters long
'//
'// 2 - Range in Excel where the object should be pasted to
'// 3 - PasteMode ["data", "image"]
'// Defines if the objects underlaying data should be
'// pasted ("data") or the the image representing the object
'// should be used
'// ****************************************************************
Private Function copyCountryChartsToExcelSheet(qvDoc, aryExportDefinition) 'as Excel.Workbook
Set Country=ActiveDocument.Fields("Country").GetPossibleValues(20000)
Dim j
for j = 1 to Val.Country - 1
qvDoc.Fields("Country").Select val.item(i).Text
Set Country = val.item(i).Text
Dim i 'as Integer
Dim objExcelApp 'as Excel.Application
Dim objExcelDoc 'as Excel.Workbook
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = True 'true '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 Fieldname
Dim Fieldvalue
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)
Fieldname = aryExportDefinition(i,4)
Fieldvalue = aryExportDefinition(i,5)
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()
chartCaption = objSource.GetCaption.Name.v
'objSource.Maximize
qvDoc.GetApplication.WaitForIdle
If (Fieldvalue = "Clear") Then
qvDoc.Fields(Fieldname, "Country dump").clear
elseif (Fieldvalue = "na") Then
Else
qvDoc.Fields(Fieldname, "Country dump").Select Fieldvalue
End If
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("A1") = chartCaption
' objExcelDoc.Sheets(sheetName).Range("A1").Font.FontStyle = "Calibri"
' objExcelDoc.Sheets(sheetName).Range("A1").Font.Size = 14
' objExcelDoc.Sheets(sheetName).Range("A1").Font.Color = RGB(252,198,10)
' objExcelDoc.Sheets(sheetName).Range("A1").VerticalAlignment = -4108
' objExcelDoc.Sheets(sheetName).Range("A1").Interior.Color = RGB(187,8,38)
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 copyCountryChartsToExcelSheet = objExcelDoc
Dim FileName
Dim FilePath
Dim File
FileName = Country & ".xlsx"
' Select Case i
' Case 0
' FileName = "Overall Chart Chart" & ".xlsx"
' 'FileName = ActiveDocument.GetVariable("vIndiaChartTitle").GetContent.String & " Bar Chart" & ".xlsx"
' Case 1
' FileName = ActiveDocument.GetVariable("vIndiaChartTitle").GetContent.String & " Data Chart" & ".xlsx"
' Case 2
' FileName = ActiveDocument.GetVariable("vUSChartTitle").GetContent.String & " Bar Chart" & ".xlsx"
' Case 3
' FileName = ActiveDocument.GetVariable("vUSChartTitle").GetContent.String & " Data Chart" & ".xlsx"
' Case 4
' FileName = ActiveDocument.GetVariable("vMexicoChartTitle").GetContent.String & " Bar Chart" & ".xlsx"
' Case 5
' FileName = ActiveDocument.GetVariable("vMexicoChartTitle").GetContent.String & " Data Chart" & ".xlsx"
' End Select
FilePath = "C:\Users\" & ActiveDocument.GetVariable("vSysUser").GetContent.String & "\Desktop"
If Right(FilePath,1) <> "\" then
FilePath = FilePath & "\"
End If
File = FilePath & FileName
objExcelDoc.SaveAs File
objExcelApp.DisplayAlerts = false
objExcelApp.Application.quit
set objExcelApp = Nothing
set objExcelDoc = Nothing
set objExcelSheet = Nothing
Next
Msgbox "Country Charts exported successfully." & Chr(10) & "File saved at " & FilePath
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
'//__________________________________________________________________
'Macro Code End Here.
Regards,
Vanraj Dinesh Bohra
