Excel VBA 手动选择一个文件夹以循环遍历其中的所有 excel 文件
Excel VBA manually choosing a folder to loop thorugh all excel files in it
我有以下 VBA 代码,用于遍历文件夹中的所有 excel 文件,并将所需的列从所有文件复制到一个文件。这是代码:
Option Explicit
Const FOLDER_PATH = "C:\Users\user\Desktop. April 2018\"
Sub ImportIncidentWorksheets()
Dim sFile As String
Dim wsTarget As Worksheet
Dim wbsource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long
Dim rowSource As Long
rowTarget = 2
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
On Error GoTo errHandler
Application.ScreenUpdating = True
Set wsTarget = Sheets("SC")
sFile = Dir(FOLDER_PATH & "*.xlsx*")
Do Until sFile = ""
Set wbsource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbsource.Worksheets("sheet1")
With wsSource
rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row)
End With
With wsTarget
.Range("A" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:E" & rowSource).Value
.Range("A" & rowTarget & ":C" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:C" & rowSource).Value
.Range("D" & rowTarget & ":D" & rowTarget + rowSource - 2).Value = wsSource.Range("E2:E" & rowSource).Value
.Range("E" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("D2:D" & rowSource).Value
.Range("F" & rowTarget).Value = wbsource.Name
End With
wbsource.Close SaveChanges:=False
rowTarget = rowTarget + rowSource - 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
Set wsSource = Nothing
Set wbsource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
如何修改第一部分文件夹的路径不会被硬编码但它会弹出 window 并且我可以手动选择文件夹?
您可以使用如下代码获取路径,而 运行 代码。
Dim strFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
strFolderPath = .SelectedItems(1)
Else
MsgBox "Path not selected!", vbExclamation
End If
End With
我有以下 VBA 代码,用于遍历文件夹中的所有 excel 文件,并将所需的列从所有文件复制到一个文件。这是代码:
Option Explicit
Const FOLDER_PATH = "C:\Users\user\Desktop. April 2018\"
Sub ImportIncidentWorksheets()
Dim sFile As String
Dim wsTarget As Worksheet
Dim wbsource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long
Dim rowSource As Long
rowTarget = 2
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
On Error GoTo errHandler
Application.ScreenUpdating = True
Set wsTarget = Sheets("SC")
sFile = Dir(FOLDER_PATH & "*.xlsx*")
Do Until sFile = ""
Set wbsource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbsource.Worksheets("sheet1")
With wsSource
rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row)
End With
With wsTarget
.Range("A" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:E" & rowSource).Value
.Range("A" & rowTarget & ":C" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:C" & rowSource).Value
.Range("D" & rowTarget & ":D" & rowTarget + rowSource - 2).Value = wsSource.Range("E2:E" & rowSource).Value
.Range("E" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("D2:D" & rowSource).Value
.Range("F" & rowTarget).Value = wbsource.Name
End With
wbsource.Close SaveChanges:=False
rowTarget = rowTarget + rowSource - 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
Set wsSource = Nothing
Set wbsource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
如何修改第一部分文件夹的路径不会被硬编码但它会弹出 window 并且我可以手动选择文件夹?
您可以使用如下代码获取路径,而 运行 代码。
Dim strFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
strFolderPath = .SelectedItems(1)
Else
MsgBox "Path not selected!", vbExclamation
End If
End With