Макрос выгрузки в EXCEL (Qlikview)

Автор piton, марта 22, 2016, 09:31:22 am

« предыдущая - следующая »

piton

марта 22, 2016, 09:31:22 am Последнее редактирование: марта 22, 2016, 06:09:02 pm от admin
Вопрос в следующем. Большие таблицы стандартной выгрузкой выгружают данные в формат CSV.
Попросили сделать выгрузку в формат XLSX. Макросов нашел два. Один использует метод копирования таблицы в буфер обмена и последующей вставкой в лист excel. В этом случае из сводной таблицы копируется объединение ячеек и при разделении значением заполняется только первая ячейка.
Сам макрос:

                         sub exportToExcel_Variant1

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

aryExport(0,0) = "objSalesPerYearAndRegion"    
aryExport(0,1) = "Sales per Region"
aryExport(0,2) = "A1"
aryExport(0,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, ...

'//objExcelWorkbook.Worksheets ("Sales per Region").Columns("A:A").AutoFit


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
   
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
            .Columns.AutoFit
            .Borders.ColorIndex = 0

            '//.UnMerge
            '//.MergeCells = 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

'//__________________________________________________________________


Второй вариант перебирает каждую ячейка и заполняет отдельно.


FUNCTION ExcelExport(objID)
set obj = ActiveDocument.GetSheetObject( objID )
w = obj.GetColumnCount
if obj.GetRowCount>1001 then
  h=1000
  else
  h=obj.GetRowCount
end if
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Add
objExcel.Worksheets(1).select()
objExcel.Visible = True
set CellMatrix = obj.GetCells2(0,0,w,h)
column = 1
for cc=0 to w-1
  objExcel.Cells(1,column).Value = CellMatrix(0)(cc).Text
  objExcel.Cells(1,column).EntireRow.Font.Bold = CellMatrix(0)(cc).Font.Bold

'objExcel.Cells(1,column).WrapText = False
  'objExcel.Cells(1,column).ShrinkToFit = False
  'objExcel.Cells(1,column).Columns.AutoFit

  objExcel.Cells(1,column).Borders.ColorIndex = 0
  column = column +1
next
c = 1
r =2
for RowIter=1 to h-1
for ColIter=0 to w-1
   objExcel.Cells(r,c).Value = CellMatrix(RowIter)(ColIter).Text
   objExcel.Cells(r,c).Font.Bold = CellMatrix(RowIter)(ColIter).Font.Bold
   objExcel.Cells(r,c).Borders.ColorIndex = 0
   'objExcel.Cells(r,c).interior.color=CellMatrix(RowIter)(ColIter).Backcolor
   c = c +1
next
r = r+1
c = 1
next
objExcel.Columns.AutoFit
END FUNCTION

SUB CallExample
ExcelExport( "objSalesPerYearAndRegion" )
END SUB


В этом варианте я не нашел как скопировать цвет фона ячейки и цвет текста ячейки.
Может кто знает как дописать в первом варианте что бы при разделении все ячейки заполнялись или во втором способе как передать цвета из qlikview.

Rolandfut

Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?

admin

Цитата: Rolandfut от марта 29, 2016, 10:00:50 am
Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?

А поподробнее можно?

HuDiK

ноября 06, 2019, 09:46:54 pm #3 Последнее редактирование: ноября 07, 2019, 02:19:36 pm от HuDiK
Вот рабочий макрос выгрузки

Sub ExcelExpwCaption
     'Set the path where the excel will be saved
     filePath = "D:\QlikViewData\Export2.xlsx"

     'Create the Excel spreadsheet
     Set excelFile = CreateObject("Excel.Application")
     excelFile.Visible = true
     'Create the WorkBook
     Set curWorkBook = excelFile.WorkBooks.Add
     'Create the Sheet
     Set curSheet = curWorkBook.WorkSheets(1)

     'Get the chart we want to export
     Set tableToExport = ActiveDocument.GetSheetObject("CH01")
     Set chartProperties = tableToExport.GetProperties
     tableToExport.CopyTableToClipboard true

     'Get the caption
     chartCaption = tableToExport.GetCaption.Name.v
     'MsgBox chartCaption

     'Set the first cell with the caption
     curSheet.Range("A1") = chartCaption
     'Paste the rest of the chart
     curSheet.Paste curSheet.Range("A2")
     excelFile.Visible = true

     'Save the file and quit excel
     curWorkBook.SaveAs filePath
     curWorkBook.Close
     excelFile.Quit

     'Cleanup
     Set curWorkBook = nothing
     Set excelFile = nothing
End Sub

Hugo

Вот тоже рабочий код, который думаю не сильно отличается от кода что выше :)
ActiveDocument.GetSheetObject("CH01").ExportBiff("D:\QlikViewData\Export2.xls")но это тоже не решает вопрос темы, и даже не сохраняет в требуемом формате... Впрочем на цвета нужно проверить!

HuDiK

Цитата: Hugo от ноября 07, 2019, 12:18:31 amВот тоже рабочий код, который думаю не сильно отличается от кода что выше :)
ActiveDocument.GetSheetObject("CH01").ExportBiff("D:\QlikViewData\Export2.xls")но это тоже не решает вопрос темы, и даже не сохраняет в требуемом формате... Впрочем на цвета нужно проверить!

Исправил. Там на самом деле этот формат xlsx. По поводу объеденных ячеек не готов сказать надо проверить. Но стиль все копирует как нужно этот макрос, он копирует полностью диаграмму и так ее вставляет со всеми форматированиями.