excel 将文件名追加到sql语句

lmvvr0a8  于 2023-05-08  发布在  其他
关注(0)|答案(1)|浏览(113)

我有下面的工作代码,它合并了一个文件夹中的数据(通过FileDialog)

Sub Test()
    Dim ws As Worksheet, SQL As String
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws
        .Columns("A:H").ClearContents
    End With
    SQL = "SELECT * FROM [Sheet1$A1:H]"
    ConsolidateData ws, "", SQL, 1
End Sub

Sub ConsolidateData(ByVal ws As Worksheet, ByVal sKeyword As String, ByVal strSql As String, ByVal iColTarget As Long)
    Dim sFolderPath As String, sFileName As String, sProvider As String, bHeadersLoaded As Boolean, i As Long
    Application.ScreenUpdating = False
    sFolderPath = GetFolderPath()
    If sFolderPath = Empty Then MsgBox "No Folder Selected", vbExclamation: Exit Sub
    sFileName = Dir(sFolderPath & sKeyword & "*.xlsx")
    Do While sFileName <> ""
        strSql = "SELECT *, '" & Left(sFileName, Len(sFileName) - 5) & "' as [FileName] FROM [Sheet1$A1:H]"
        sProvider = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFolderPath & sFileName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
        On Error GoTo ErrHandler
        With CreateObject("ADODB.Recordset")
            .Open strSql, sProvider
            If Not bHeadersLoaded And Not .EOF Then
                For i = 0 To .Fields.Count - 1
                    ws.Cells(1, iColTarget + i) = .Fields(i).Name
                Next i
                bHeadersLoaded = True
            End If
            ws.Cells(Rows.Count, iColTarget).End(xlUp).Offset(1).CopyFromRecordset .DataSource
            .Close
        End With
ContinueLoop:
        sFileName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Done", 64
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        Debug.Print sFileName: Err.Clear: Resume ContinueLoop
    End If
End Sub

Function GetFolderPath() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.InitialFileName = ThisWorkbook.Path
    fd.Title = "Select Folder"
    If fd.Show = -1 Then GetFolderPath = fd.SelectedItems(1) & "\"
End Function

代码在文件名的第一列(A列)添加额外的列。但我得把这一栏放在最后。我应该在代码中修改什么?问题也贴在这里https://eileenslounge.com/viewtopic.php?f=30&t=39636

xa9qqrwz

xa9qqrwz1#

你不需要通过SQL添加它:

'...
        '...
        Set rs = CreateObject("ADODB.Recordset")
        With rs
            .Open strSql, sProvider
            
            If Not bHeadersLoaded And Not .EOF Then
                For i = 0 To .Fields.Count - 1
                    ws.Cells(1, iColTarget + i) = .Fields(i).Name
                Next i
                ws.Cells(1, iColTarget + .Fields.Count) = "FileName"
                bHeadersLoaded = True
            End If
            With ws.Cells(Rows.Count, iColTarget).End(xlUp).Offset(1)
                .CopyFromRecordset rs
                .Offset(0, rs.Fields.Count).Resize(rs.RecordCount).Value = FileBaseName(sFileName)
            End With
            
            .Close
        End With
        '...
        '...

FileBaseName函数:

Function FileBaseName(fileName As String) As String
    FileBaseName = CreateObject("scripting.filesystemobject").getbasename(fileName)
End Function

相关问题