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

您应该将multiselect设置为on。尝试使用以下代码链接或导入文件，然后合并它们：

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

Answer 2

您可以轻松地将所有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

访问VBA对话框以导入多个CSV和xls并进行查询

2 个答案: