Создание сценария VBA для автоматизации загрузки и преобразования данных.

Question

Я обрабатываю данные из симуляции. Мониторы из симуляции - это файлы CSV, но на симуляцию приходится около 20, и каждый из них неудобно загружать в Excel и преобразовывать значения в тип десятичного числа.

В настоящее время у меня есть модуль VBA, который автоматизирует загрузку следующих значений:

  '''  Sub Macro4()

ActiveWorkbook.Queries.Add Name:="oil-produced", Formula _
    := _
    "let" & Chr(13) & "" & Chr(10) & "    Source = Table.FromColumns({Lines.FromBinary(File.Contents(""C:\Users\user\Documents\run6\results\oil-produced.out""), null, null, 1252)})," & Chr(13) & "" & Chr(10) & "    #""Split Column by Delimiter"" = Table.SplitColumn(Source, ""Column1"", Splitter.SplitTextByDelimiter("" "", QuoteStyle.Csv), {""Column1.1"", ""C" & _
    "olumn1.2"", ""Column1.3""})," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Split Column by Delimiter"",{{""Column1.1"", type number}, {""Column1.2"", type number}, {""Column1.3"", type number}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
    "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""oil-produced"";Extended Properties=""""" _
    , Destination:=Range("$A$1")).QueryTable
    .CommandType = xlCmdSql
    .CommandText = Array("SELECT * FROM [oil-produced]")
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = "oil_produced"
    .Refresh BackgroundQuery:=False
End With
Application.Run "getUnits"
  End Sub

Файл данных находится в папке C: \ Users \ user \ Documents \ run6 \ results \ нефтедобывающий, и файл данных называется нефтедобывающим.

Мне нужно вызвать несколько таких файлов данных и папку, в которой эти файлы находятся в изменениях. Я хотел бы иметь возможность параметризовать папку файла и имя файла данных в начале макроса, чтобы я мог легко изменить местоположение файла без корректировки каждого запроса и создать для данных от l oop до l oop файлы, чтобы подпрограмма не была такой длинной и громоздкой.

Я попытался сделать это, указав имя папки в виде строки и подставив его в запрос к книге; однако я получаю сообщение об ошибке, указывающее, что указанный путь к файлу должен быть действительным абсолютным путем.

У кого-нибудь есть предложения относительно альтернативных способов сделать это?

Answer 1

Я не знаю, откуда у вас информация о ваших запросах, поэтому я настроил таблицу для ее хранения следующим образом:

Имя таблицы: TableParams

Проверьте комментарии к коду и настройте его в соответствии с вашими потребностями.

Код:

Option Explicit

Public Sub ProcessQueries()

    Dim sourceTable As ListObject
    Dim sourceListRow As ListRow

    Dim queryName As String
    Dim sourceFolder As String
    Dim sourceFileName As String
    Dim targetSheetName As String
    Dim targetCellAddr As String

    Set sourceTable = Range("TableParams").ListObject

    ' Loop through each row
    For Each sourceListRow In sourceTable.ListRows


        queryName = sourceListRow.Range.Cells(1, 1).Value ' -> ' Second argument of cells is the table's column number
        sourceFolder = sourceListRow.Range.Cells(1, 2).Value
        sourceFileName = sourceListRow.Range.Cells(1, 3).Value
        targetSheetName = sourceListRow.Range.Cells(1, 4).Value
        targetCellAddr = sourceListRow.Range.Cells(1, 5).Value

        OutputQuery queryName, sourceFolder, sourceFileName, targetSheetName, targetCellAddr

    Next sourceListRow


End Sub

Private Sub OutputQuery(ByVal queryName As String, ByVal sourceFolder As String, _
                        ByVal sourceFileName As String, ByVal targetSheetName As String, ByVal targetCellAddr As String)

    Dim targetSheet As Worksheet
    Dim sourceQueryFormula As String

    sourceQueryFormula = "let" & Chr(13) & "" & Chr(10) & "    " & _
                         "Source = Table.FromColumns({Lines.FromBinary(" & _
                         "File.Contents(" & Chr(34) & sourceFolder & "\" & sourceFileName & Chr(34) & ")" & _
                         ", null, null, 1252)})," & Chr(13) & "" & Chr(10) & "    #""Split Column by Delimiter"" = Table.SplitColumn(Source, ""Column1"", Splitter.SplitTextByDelimiter("" "", QuoteStyle.Csv), {""Column1.1"", ""C" & _
                         "olumn1.2"", ""Column1.3""})," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Split Column by Delimiter"",{{""Column1.1"", type number}, {""Column1.2"", type number}, {""Column1.3"", type number}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""

    ' Delete previous query if exists
    On Error Resume Next
    ThisWorkbook.Queries(queryName).Delete
    On Error GoTo 0

    ' Change to use thisworkbook instead of active workbook
    ThisWorkbook.Queries.Add Name:=queryName, Formula:=sourceQueryFormula

    ' Add new worksheet and change it's name
    If Not WorksheetExists(targetSheetName) Then
        Set targetSheet = ThisWorkbook.Worksheets.Add
        targetSheet.Name = targetSheetName
    Else
        Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
    End If

    With targetSheet.ListObjects.Add(SourceType:=0, source:= _
                                     "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & queryName & ";Extended Properties=""""" _
                                     , destination:=targetSheet.Range(targetCellAddr)).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [" & queryName & "]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = queryName
        .Refresh BackgroundQuery:=False
    End With

    ' Next line don't need Application.Run if your calling the macro in the same book
    'Application.Run "getUnits"
    getUnits

End Sub

Private Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
' Credits: https://stackoverflow.com/a/6688482/1521579
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

Дайте мне знать, если это работает

Answer 2

Я бы попробовал что-то вроде этого, если бы я получил вас.

Function CompleteString(strPath As String, strFileName As String, _
                    Optional blnAdditionalQuotes = True)
    CompleteString = IIf(blnAdditionalQuotes, Chr(34), vbNullString) & _
                        "\" & strFileName & _
                        IIf(blnAdditionalQuotes, Chr(34), vbNullString)
End Function

, а затем использовал бы так

......"File.Contents(" & CompleteString ("C:\Users\user\Documents\run6\results\oil-produced","Oil Produced.out") & "),null, null"...….