Вопрос в следующем. Большие таблицы стандартной выгрузкой выгружают данные в формат 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.
Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?
Цитата: Rolandfut от 29 марта 2016, 10:00:50
Не нашел в форуме ответ на этот вопрос, если есть - ткните пожайлуста пальцем.
А нужнов от что: перекидывать данные из Excel в базу, причем регулярно.
Кто что подскажет?
А поподробнее можно?
Вот рабочий макрос выгрузки
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
Вот тоже рабочий код, который думаю не сильно отличается от кода что выше :)
ActiveDocument.GetSheetObject("CH01").ExportBiff("D:\QlikViewData\Export2.xls")
но это тоже не решает вопрос темы, и даже не сохраняет в требуемом формате... Впрочем на цвета нужно проверить!
Цитата: Hugo от 07 ноября 2019, 12:18:31 Вот тоже рабочий код, который думаю не сильно отличается от кода что выше :)
ActiveDocument.GetSheetObject("CH01").ExportBiff("D:\QlikViewData\Export2.xls")
но это тоже не решает вопрос темы, и даже не сохраняет в требуемом формате... Впрочем на цвета нужно проверить!
Исправил. Там на самом деле этот формат xlsx. По поводу объеденных ячеек не готов сказать надо проверить. Но стиль все копирует как нужно этот макрос, он копирует полностью диаграмму и так ее вставляет со всеми форматированиями.