qlikview marco export EXCEL

gistfile1.txt

Sub ExcelPrint
	Call exportToExcel_ALL()
End Sub 
Public Function exportToExcel_ALL()
Dim aryExport(14,3)

aryExport(0,0) = "CH57"
aryExport(0,1) = "直营业绩周报表"
aryExport(0,2) = "A1" 				
aryExport(0,3) = "data"


aryExport(1,0) = "CH59"
aryExport(1,1) = "直营业绩周报表"
aryExport(1,2) = "A11" 				
aryExport(1,3) = "data"

aryExport(2,0) = "CH60"
aryExport(2,1) = "直营业绩周报表"
aryExport(2,2) = "A21" 				
aryExport(2,3) = "data"

aryExport(3,0) = "CH69"
aryExport(3,1) = "直营业绩周报表"
aryExport(3,2) = "A31" 				
aryExport(3,3) = "image"

aryExport(4,0) = "CH61"
aryExport(4,1) = "直营业绩周报表"
aryExport(4,2) = "A46" 				
aryExport(4,3) = "data"

aryExport(5,0) = "CH86"
aryExport(5,1) = "直营业绩周报表"
aryExport(5,2) = "A250" 				
aryExport(5,3) = "data"

aryExport(6,0) = "CH84"
aryExport(6,1) = "直营营运周报"
aryExport(6,2) = "A1" 				
aryExport(6,3) = "data"

aryExport(7,0) = "CH82"
aryExport(7,1) = "直营营运周报"
aryExport(7,2) = "A11" 				
aryExport(7,3) = "data"


aryExport(8,0) = "CH81"
aryExport(8,1) = "直营营运周报"
aryExport(8,2) = "A21" 				
aryExport(8,3) = "data"

aryExport(9,0) = "CH85"
aryExport(9,1) = "直营营运周报"
aryExport(9,2) = "A31" 				
aryExport(9,3) = "data"

aryExport(10,0) = "CH71"
aryExport(10,1) = "店铺业绩报表"
aryExport(10,2) = "A1" 				
aryExport(10,3) = "data"

aryExport(11,0) = "CH73"
aryExport(11,1) = "店铺业绩报表"
aryExport(11,2) = "A201" 				
aryExport(11,3) = "data"

aryExport(12,0) = "CH74"
aryExport(12,1) = "店铺业绩报表"
aryExport(12,2) = "A401" 				
aryExport(12,3) = "data"

aryExport(13,0) = "CH75"
aryExport(13,1) = "店铺业绩报表"
aryExport(13,2) = "A601" 				
aryExport(13,3) = "data"

aryExport(14,0) = "CH76"
aryExport(14,1) = "店铺业绩报表"
aryExport(14,2) = "A801" 				
aryExport(14,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, ...
msgbox "导出完成！"
End Function 
	




'// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'// 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 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
   
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 
'//__________________________________________________________________
Public Function AssociateField(SelectField,DateField,npa)
dim i,Count,osf,Orf,sSelectValues,fv
Set oSf = ActiveDocument.Fields(SelectField)
    sSelectValues = LoadSelect(SelectField,npa)
    Set oRf=ActiveDocument.Fields(DateField)
    Set fv=orf.GetNoValues
    fv.Add
    fv(0).text=cstr(year(now)*100+month(now))
    fv(0).IsNumeric=false
    orf.SelectValues fv'设定年月为当前天所在月
    For i = 0 To Ubound(sSelectValues) - 1
     Set fv=osf.GetNoValues
     orf.SelectValues fv
     fv.Add
     fv(0).text=sSelectValues(i)
     fv(0).IsNumeric=false  
     osf.SelectValues fv'设定为一家经销商
     Call exportToExcel_ALL(sSelectValues(i),year(now)*100+month(now))
     
Next

End Function

Function LoadSelect(fieldname,npa)
    Dim Fields, i 'The Active Stage that is selected
    Dim ActiveStage()   'a Array store the list of Active stage that is selected
     
     Select Case nPa
     case 0
     	
     	
       Set Fields = ActiveDocument.Fields(fieldname).GetSelectedValues
     case 1
     	

     	Set Fields = ActiveDocument.Fields(fieldname).GetDeselectedValues
     	'msgbox fields.count
     case 2
     	'msgbox fields.count
       Set Fields = ActiveDocument.Fields(fieldname).GetOptionalValues
     case 3
	    'msgbox fields.count
       Set Fields = ActiveDocument.Fields(fieldname).GetExcludedValues 
         case 4
         'msgbox fields.count
         Set Fields = ActiveDocument.Fields(fieldname).GetpossibleValues
         Case else
         'LoadSelect =Null :exit function  
    End Select
    'msgbox fields.count
    ReDim ActiveStage(Fields.Count)
    For i = 0 To Fields.Count - 1
        If (Len(Fields.Item(i).Text) > 0) Then
            ActiveStage(i) = Fields.Item(i).Text
           'msgbox ActiveStage(i)
        End If
    Next
    LoadSelect = ActiveStage '选中字段值数组作为函数值返回给主调函数
End Function