我有下面的工作代码,它合并了一个文件夹中的数据(通过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
1条答案
按热度按时间xa9qqrwz1#
你不需要通过SQL添加它:
FileBaseName
函数: