Доступ к диалоговому окну VBA для импорта нескольких CSV и xls и запроса

Question

Мне нужен VBA для импорта нескольких файлов CSV и xls с использованием диалогового окна для конечного пользователя.Количество файлов меняется каждый раз, а также имя и местоположение файлов на сервере (\ myservername).Часто файлы имеют не заголовки в первой строке, а в 5-й или 6-й, потому что они содержат заголовок отчета и информацию в первых строках.Файлы имеют по крайней мере один столбец с тем же именем (Item_Number), но с повторяющимися записями в этом конкретном столбце.Количество полей и имен не совпадают для каждого файла, но в каждом файле может быть несколько полей.В конце мне нужен запрос в том же коде, чтобы объединить все новые таблицы и экспортировать все в файл Excel с диалоговым окном, чтобы выбрать место, где его сохранить.Первичным ключом среди таблиц всегда является Item_Number, но могут быть дубликаты, как указано выше.Спасибо

Обнаружен код, который не работает.

Function File_Dialog_Box() As String

On Error GoTo catchError
txtPath = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Dim directory As String, fileName As String, total As Integer
Dim fd As Object
Set fd = Application.FileDialog(3)

With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Custom Excel Files", "*.xlsx, *.csv, *.xls"

If .Show = True Then
txtPath = Dir(.SelectedItems(1))
End If
txtPath = fso.GetFileName(.SelectedItems(1))
End With
File_dailog = txtPath
exit_catchError:
Exit Function
catchError:
If Err.Number = 5 Then
Exit Function
End If

MsgBox ("File has been uploaded. Do you want to upload another file?")

End Function

Если конечный пользователь не выбрал больше файлов, VBA начинает запрос с текущих таблиц.

Answer 1

Вы можете легко импортировать все файлы CSV в одну таблицу (очевидно, все файлы должны иметь одну и ту же схему).

Private Sub Command1_Click()

Dim strPathFile As String, strFile As String, strPath As String
        Dim strTable As String, strBrowseMsg As String
        Dim blnHasFieldNames As Boolean

        ' Change this next line to True if the first row in EXCEL worksheet
        ' has field names
        blnHasFieldNames = False

        strBrowseMsg = "Select the folder that contains the CSV files:"

        strPath = "C:\your_path\"

        If strPath = "" Then
              MsgBox "No folder was selected.", vbOK, "No Selection"
              Exit Sub
        End If

        ' Replace tablename with the real name of the table into which
        ' the data are to be imported
        strTable = "tablename"

        strFile = Dir(strPath & "\*.csv")
        Do While Len(strFile) > 0
              strPathFile = strPath & "\" & strFile

        DoCmd.TransferText acImportDelim, , strTable, strPathFile, blnHasFieldNames

        ' Uncomment out the next code step if you want to delete the
        ' EXCEL file after it's been imported
        '       Kill strPathFile

              strFile = Dir()
        Loop
End Sub

Или ... импортировать каждый файл CSV в отдельную таблицу, уникальную длякаждый файл CSV.

Private Sub Command2_Click()

 Dim strPathFile As String
 Dim strFile As String
 Dim strPath As String
 Dim strTable As String
 Dim blnHasFieldNames As Boolean

 ' Change this next line to True if the first row in CSV worksheet
 ' has field names
 blnHasFieldNames = True

 strPath = "C:\your_path\"

 ' Replace tablename with the real name of the table into which
 ' the data are to be imported

 strFile = Dir(strPath & "*.csv")


 Do While Len(strFile) > 0
       strTable = Left(strFile, Len(strFile) - 4)
       strPathFile = strPath & strFile
       DoCmd.TransferText acImportDelim, , strTable, strPathFile, blnHasFieldNames

 ' Uncomment out the next code step if you want to delete the
 ' EXCEL file after it's been imported
 '       Kill strPathFile

       strFile = Dir()
 Loop

End Sub

Answer 2

Вы должны включить множественный выбор.попробуйте следующий код, чтобы связать или импортировать файлы, а затем объединить их:

Sub Importer()
    Dim fDialog As Office.FileDialog
    Dim FileName As Variant
    Dim TableName As String
    Dim TableCnt As Integer
Dim FileFlag As Integer

    '......... File Dialog ............
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .AllowMultiSelect = True
        .Title = "Select KPI csv files."
        .Filters.Add "MY FILE TYPES", "*.csv;*.xls;*.xlsx", 1
        .FilterIndex = 1
        .InitialFileName = Environ("userprofile") & "\Desktop\Q3\"
        If .Show = False Then
            Exit Sub
        End If
    End With

    '............ Import files ................
    DoCmd.SetWarnings False
    For Each FileName In fDialog.SelectedItems
        Select Case Right(FileName, 4)
            Case ".csv"
                FileFlag = CheckCSVFileType(CStr(FileName))
                If FileFlag > 0 Then
                    '... set first row of importing csv file.
                    '... You should create an importing specification then go to navigation pane, set settings
                    '... to show system objects, then find MSysIMEXSpecs hidden table.
                    '... Your defined specifications settings are there.
                    '... find specID for your csv importing specification,
                    '... and change 6666 in the bellow to that number.
                    DoCmd.RunSQL ("UPDATE " & _
                        "MSysIMEXSpecs SET MSysIMEXSpecs.StartRow =" & FileFlag & _
                        " WHERE (((MSysIMEXSpecs.SpecID)=6666)); ")
                    '... Linking or importing file
                    DoCmd.TransferText _
                        acLinkDelim, _
                        "YourSpecificationName", _
                        "Table Name in access(will be merged at the end)", _
                        FileName, _
                        True
                End If
            Case ".xls", "xlsx"
                ImportXLSFileType CStr(FileName)
        End Select
    Next FileName
    DoCmd.SetWarnings True
End Sub

'.. This Function Check text file and search 10 first row to find special string which shows your data header.
'.. then return row number of heading row. If no such row found in first 10 rows, return -1.
Function CheckFileType(FileName As String) As Integer
    Dim DataStr As String
    Dim BlankCheck As Integer
    Open FileName For Input Access Read As #1
    BlankCheck = 0
    CheckFileType = -1
    Do
        BlankCheck = BlankCheck + 1
        Line Input #1, DataStr
        If InStr(1, DataStr, "Your expected string Or part of your expected header") > 0 Then
            CheckFileType = BlankCheck
        End If
    Loop While Not EOF(1) And BlankCheck < 10 And CheckFileType = -1
    Close #1
End Function

Sub ImportXLSFileType(FileName As String)
    Dim DataSheet As Worksheet
    Dim DataBook As Workbook
    Dim LastCell As String
    Dim FR As Range
    Dim DataRange As String
    Dim DelRow As Integer

    Set DataBook = Workbooks.Open(FileName, 0, False)
    DataBook.Application.WindowState = xlMinimized
    For Each DataSheet In DataBook.Worksheets
        With DataSheet
            Set FR = .Range("1:5").Find(what:="BTSNAME", lookat:=xlWhole)
            If Not FR Is Nothing Then
                DoCmd.TransferSpreadsheet _
                    acLink, _
                    acSpreadsheetTypeExcel12Xml, _
                    "Your table name in access", _
                    FileName, _
                    True, _
                    .Name & FR.Address & ":" & .Range("A" & .cells.Rows.Count).End(xlTop).End(xlRight).Address
                DoCmd.RunSQL "INSERT INTO [Importing Files] (FilePath, SheetName, Range, FileType) SELECT """ & _
                    FileName & """,""" & .Name & """,""" & DataRange & """," & hka2Gxls & ";"
            End If
        End With
    Next
End Sub