我正在尝试创建一个循环 VBA 宏来:
- 打开名为
New
的文件夹中的第一个文件 - 复制
Defined Name
单元格区域中的数据行export_data
- 将其粘贴到我当前工作簿中
Sheet1
上A1
的新行 - 关闭而不保存从中导入数据的文件,并将其移动到
Archived
文件夹 - 重复此操作,直到
New
文件夹中不再有任何文件。
我的文件结构如下:
New
文件夹中的所有文件都是相同的(名称除外).xlsm
文件。每个都有一个名为 export_data
的定义名称
单元格范围,其中包含我需要导入到 Dashboard.xlsm
中的单行单元格。
我希望宏使用 New
和 Archived
文件夹的相对路径,因为它允许我将整组文件移动到任何地方并且仍然可以工作。
目前我已经尽可能地适应了代码 from this post试图让宏移动文件:
Option Explicit
Const FOLDER_PATH = "C:\Users\OneDrive\Projects\Audit Sheet\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 2
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
'Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
'import the data
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
'rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
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
最佳答案
我建议使用FileSystemObject
进行路径和文件引用以及文件移动。使用 ThisWorkbook.Path
作为相对路径的基础(基于 OP 中的仪表板工作簿位置)
Sub Demo()
Dim fso As FileSystemObject
Dim fldBase As Folder
Dim fldNew As Folder
Dim fldArchived As Folder
Dim fWb As File
Dim wb As Workbook
Dim ws As Worksheet
Dim nm As Name
Dim rng As Range
Dim wsDashboard As Worksheet
Dim OldCalc As XlCalculation
Const NAMED_RANGE = "export_data"
On Error GoTo EH:
Application.ScreenUpdating = False
OldCalc = Application.Calculation
Application.Calculation = xlCalculationManual
' Set reference to data destination sheet
Set wsDashboard = ThisWorkbook.Worksheets("ExportData") '<-- adjust to your ws name in Dashboard
Set fso = New FileSystemObject
Set fldBase = fso.GetFolder(ThisWorkbook.Path)
'Check if \New and \Archive exist
If Not fso.FolderExists(ThisWorkbook.Path & "\New") Then Exit Sub
If Not fso.FolderExists(ThisWorkbook.Path & "\Archived") Then Exit Sub
Set fldNew = fso.GetFolder(ThisWorkbook.Path & "\New")
Set fldArchived = fso.GetFolder(ThisWorkbook.Path & "\Archived")
For Each fWb In fldNew.Files
If fWb.Name Like "*.xls*" Then
' Open File
Set wb = Application.Workbooks.Open(Filename:=fWb.Path, ReadOnly:=True)
Set nm = wb.Names(NAMED_RANGE)
Set rng = nm.RefersToRange
' Copy Data
With wsDashboard
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
End With
' Close File
wb.Close SaveChanges:=False
' Move File
fso.MoveFile Source:=fWb.Path, Destination:=fldArchived.Path & "\" & fWb.Name
End If
Next
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = OldCalc
Exit Sub
EH:
Stop ' <--- For debug purposes
Resume CleanUp
End Sub
不要忘记添加对 FileSystemObject 的引用,或转换为后期绑定(bind) as shown here -
关于vba - 循环 VBA 宏以打开文件夹中的文件、导入行,然后使用相对路径移动到另一个文件夹,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/50889870/