excel - 将文件夹中的多个工作簿合并到一个文件中,每个工作簿作为单独的工作表,文件名=工作表名 - Excel VBA 宏
问题描述
我有一个包含许多 Excel 工作簿的文件夹(技术报告,每个工作簿只有一个名为Sheet的工作表),我需要做一个摘要工作簿,其中文件夹中的每个工作簿(报告)都将作为单个工作表插入,该工作表将被命名使用文件夹中的文件名。
我有这个由两部分组成的代码,它首先重命名代码文件夹中所述的工作簿(报告)中的工作表(最好是一个弹出窗口),然后打开一个弹出窗口来选择文件(报告)所在的文件夹结合起来。
有没有办法一次自动完成所有事情?
同样在以下代码中,我对带有点“。”的文件名有疑问,例如。对于报告BAHU76 -CL19.1.1-它只是给出了一个名称BAHU76 -CL19
预先感谢您的帮助!
Sub RenSheets()
Dim MyFolder As String
Dim MyFile As String
Dim wbname As String
MyFolder = "C:\excel"
MyFile = Dir(MyFolder & "\*.xlsx")
Application.ScreenUpdating = False
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
With ActiveWorkbook
wbname = Left(.Name, InStr(.Name, ".") - 1)
.Sheets(1).Name = wbname
.Close savechanges:=True
End With
MyFile = Dir
Loop
Application.ScreenUpdating = True
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(wksCurSheet.Name, 31)
Next
wbkSrcBook.Close savechanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
解决方案
这样的事情可能会帮助你。
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\your_path_here\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:J100")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
当然,您可以使用动态范围,而不是固定范围。查看下面的链接以获取有关此概念的更多信息。
推荐阅读
- arduino - Arduino 顺序软件serial.print() 覆盖自身
- xcode - 为 Apple M1 和较旧的英特尔设备构建 FFTW
- javascript - 关闭浏览器时如何更新数据库?
- mysql - 当我在 MySQL 中删除自己的变量时出错
- kotlin - 聚合根 id 引用字段命名约定
- php - 保存产品元字段以在 WooCommerce 中订购项目元
- python - 上传文件时如何使用Post-save Signal,修改文件前后保存?
- python - 创建具有多个 if 条件的列
- kubernetes - HAProxy 不适用于后端的 Kubernetes NodePort(裸机)
- nlp - 如何在 selfAttention 类中使用多头选项?