Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 01.11.2019, 13:53   #1
unbanned
Форумчанин
 
Аватар для unbanned
 
Регистрация: 23.11.2010
Сообщений: 530
По умолчанию Экспорт из модели данных в *.csv (PowerQuery)

Всем доброго времени суток!

Хочу поделится способом экспорта из модели данных в *.csv.
Думаю кому-нибудь пригодится, т.к. поиск на эту тему выдает очень мало информации.
Также буду рад комментариям по поводу написанного кода (частично мой, частично скопипащено). Сразу хочу сказать, что программистом я не являюсь

Код:
'Экспорт в CSV из модели данных PowerQuery
'31.10.2019

'Для работы нужно активировать библиотеки (Tools -> Preferences...):
'-Microsoft Scripting Runtime
'-Microsoft ActiveX Data Objects 6.1 Library

Option Explicit

Public FSO     As New FileSystemObject

Sub main()

    Dim ModelList As String
    Dim OFD    As FileDialog
    Dim i      As Integer
    Dim ModelNum As Integer
    Dim tmp    As String

    ModelList = "Доступные в данной книге модели:" + Chr(10) + Chr(13) + Chr(13)
    If ThisWorkbook.Model.ModelTables.Count <> 0 Then
        For i = 1 To ThisWorkbook.Model.ModelTables.Count
            ModelList = ModelList & i & ". " & ThisWorkbook.Model.ModelTables.Item(i).Name & Chr(10) & Chr(13)
        Next i
    Else

        ModelList = ModelList & " Нет доступных моделей"

    End If


ModelNameInput:

    ModelNum = 0
    tmp = InputBox(ModelList, "Введите номер модели")

    If IsNumeric(tmp) Then
        If CInt(tmp) > ThisWorkbook.Model.ModelTables.Count Or CInt(tmp) <= 0 Then
            MsgBox "Incorrect Model num", vbOKOnly
            GoTo ModelNameInput
        Else
            ModelNum = CInt(tmp)
        End If
    Else
        If tmp <> "" Then
            MsgBox "Incorrect Model num", vbOKOnly
            GoTo ModelNameInput
        Else
            Exit Sub
        End If
    End If

    Set OFD = Application.FileDialog(msoFileDialogSaveAs)

    OFD.Title = "Выберите путь и имя файла"
    OFD.ButtonName = "Сохранить"
    OFD.FilterIndex = 15
    OFD.InitialFileName = "export.csv"
    OFD.InitialView = msoFileDialogViewLargeIcons

    If OFD.Show <> 0 Then
        Call ExportToCsv(ThisWorkbook.Model.ModelTables.Item(ModelNum).Name, OFD.SelectedItems.Item(1))
    Else
    End If

    Set OFD = Nothing
End Sub

Public Sub ExportToCsv(QueryName As String, ExportPath As String)

    Dim wbTarget As Workbook
    Dim ws     As Worksheet
    Dim rs     As Object
    Dim sQuery As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Set wbTarget = ActiveWorkbook

    Err.Clear

    On Error GoTo ErrHandler

    wbTarget.Model.Initialize

    sQuery = "EVALUATE '" & QueryName & "'"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sQuery, wbTarget.Model.DataModelConnection.ModelConnection.ADOConnection
    Dim CSVData As String
    Call WriteRecordsetToCSV(rs, ExportPath, True)

    rs.Close
    Set rs = Nothing
    MsgBox "Save success", vbOKOnly

ExitPoint:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    Set rs = Nothing
    Exit Sub

ErrHandler:
    MsgBox "An error occurred - " & Err.Description, vbOKOnly
    Resume ExitPoint
End Sub

Public Sub WriteRecordsetToCSV(rsData As ADODB.Recordset, _
        FileName As String, _
        Optional ShowColumnNames As Boolean = True, _
        Optional NULLStr As String = "")

    Dim TxtStr As TextStream
    Dim i As Long, CSVData As String

    Set TxtStr = FSO.CreateTextFile(FileName, True)

    If ShowColumnNames Then
        For i = 0 To rsData.Fields.Count - 1
            CSVData = CSVData & ";""" & Mid(rsData.Fields(i).Name, InStr(1, rsData.Fields(i).Name, "[") + 1, Len(rsData.Fields(i).Name) - InStr(1, rsData.Fields(i).Name, "[") - 1) & """"
        Next i

        CSVData = Mid(CSVData, 2) & vbNewLine
        TxtStr.Write CSVData
    End If

    Do While rsData.EOF = False
        CSVData = """" & rsData.GetString(adClipString, 1000, """;""", """" & vbNewLine & """", NULLStr)
        CSVData = Left(CSVData, Len(CSVData) - IIf(rsData.EOF, 3, 2))
        TxtStr.Write CSVData
    Loop

    TxtStr.Close

End Sub
unbanned вне форума Ответить с цитированием
Старый 01.11.2019, 20:33   #2
AndVGri
Форумчанин
 
Регистрация: 10.02.2012
Сообщений: 109
По умолчанию

Доброе время суток.
Спасибо. Но как правило для этих целей всё же удобнее пользоваться DAX Studio
AndVGri вне форума Ответить с цитированием
Старый 02.11.2019, 02:47   #3
unbanned
Форумчанин
 
Аватар для unbanned
 
Регистрация: 23.11.2010
Сообщений: 530
По умолчанию

вообщем-то так и есть. Но! не всегда есть возможность ставить сторонний софт.
за подсказку спасибо, попробую поюзать.
unbanned вне форума Ответить с цитированием
Старый 08.11.2019, 20:34   #4
nacimjon
Новичок
Джуниор
 
Регистрация: 24.11.2010
Сообщений: 1
По умолчанию

У меня выходить ощибка User definde type definde
как решить данную ощибку
nacimjon вне форума Ответить с цитированием
Старый 11.11.2019, 11:19   #5
unbanned
Форумчанин
 
Аватар для unbanned
 
Регистрация: 23.11.2010
Сообщений: 530
По умолчанию

Цитата:
Сообщение от nacimjon Посмотреть сообщение
У меня выходить ощибка User definde type definde
как решить данную ощибку
скорее всего дело в этом:

Цитата:
Сообщение от unbanned Посмотреть сообщение
'Для работы нужно активировать библиотеки (Tools -> Preferences...):
'-Microsoft Scripting Runtime
'-Microsoft ActiveX Data Objects 6.1 Library
unbanned вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
PowerQuery или формулами: Выбрать данные по последним заполненным sanych_09 Microsoft Office Excel 1 23.11.2017 12:34
C++ Базы данных. Экспорт данных из access в существующий шаблон word hunter24 Помощь студентам 1 07.11.2016 18:35
Экспорт модели и текстуры в 3DMax AlexMik Gamedev - cоздание игр: Unity, OpenGL, DirectX 1 11.04.2012 20:08
[Qt] Отображение в QListView данных модели newStudent Qt и кроссплатформенное программирование С/С++ 3 17.06.2011 15:33
Модели данных ГИС Sweta Помощь студентам 0 20.01.2011 10:16