Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Не получили письмо с кодом активации?
Ноябрь 21, 2017, 03:44:01 am

Автор Тема: Макрос выгрузки в EXCEL (Qlikview)  (Прочитано 1591 раз)

Оффлайн piton

  • Новичок
  • *
  • Сообщений: 22
  • Рейтинг: +5/-0
    • Просмотр профиля
Макрос выгрузки в EXCEL (Qlikview)
« : Март 22, 2016, 09:31:22 am »
Вопрос в следующем. Большие таблицы стандартной выгрузкой выгружают данные в формат 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

  • Стажер
  • *
  • Сообщений: 1
  • Страна: ar
  • Рейтинг: +0/-0
    • Просмотр профиля
Макрос выгрузки в EXCEL Qlikview
« Ответ #1 : Март 29, 2016, 10:00:50 am »
Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?

Оффлайн admin

  • Administrator
  • Hero Member
  • *****
  • Сообщений: 981
  • Страна: ru
  • Рейтинг: +97/-0
    • Просмотр профиля
Re: Макрос выгрузки в EXCEL Qlikview
« Ответ #2 : Март 29, 2016, 05:19:08 pm »
Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?
А поподробнее можно?

Неофициальный форум пользователей QlikView & Qlik Sense

Re: Макрос выгрузки в EXCEL Qlikview
« Ответ #2 : Март 29, 2016, 05:19:08 pm »