excel - VBA遍历工作簿和工作表名称并复制到主控表中的现有工作表名称
问题描述
我有许多具有不同工作表名称的工作簿(尽管并非每个文件都有每个工作表,但它们始终相同)和一个具有所有可能工作表名称的主文件。我正在尝试遍历文件夹中的所有工作簿,并且:
打开每个文件,遍历所有工作表并从每个工作表复制特定范围内的所有粗体单元格
将此范围粘贴到主电子表格的相应(= 同名)工作表中
我有一个适用于第一张工作表的代码,但我不知道如何遍历工作表名称并将它们与主工作表匹配,特别是因为工作表可以按不同的顺序排列并且工作簿并不总是包含所有床单。
Sub LoopThroughFiles6()
Dim firstEmptyRow As Long
Dim SourceFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook, attachmentWorkSheet As Worksheet
Dim copyRng As Range
Dim cell As Range
Dim tempRange As Range
SourceFolder = "C:\Users\x0514\Desktop\test\"
StrFile = Dir(SourceFolder & "*.xlsx")
Do While Len(StrFile) > 0
Debug.Print StrFile
Set attachmentWorkBook = Workbooks.Open(Filename:=SourceFolder & StrFile)
For Each attachmentWorkSheet In attachmentWorkBook.Worksheets
With ThisWorkbook.Worksheets(attachmentWorkSheet.Name)
'#firstEmptyRow returns the first empty row in column B
firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 2
'#paste file name to Column A
.Range("A" & firstEmptyRow) = StrFile
'#paste data in column B
Set copyRng = attachmentWorkSheet.Range("A1:CA4")
'# Select only bold cells in this range
For Each cell In copyRng
If cell.Font.Bold = True Then
If tempRange Is Nothing Then
Set tempRange = cell
Else
Set tempRange = attachmentWorkBook.Application.Union(tempRange, cell)
'# code throws an error here, I suspect I did not correctly specify the open workbook
End If
End If
Next cell
If Not tempRange Is Nothing Then
tempRange.Select
End If
.Range("B" & firstEmptyRow).Resize(tempRange.Rows.Count, tempRange.Columns.Count).Value = tempRange.Value
End With
Next
attachmentWorkBook.Close SaveChanges:=False
StrFile = Dir
Loop
End Sub
解决方案
Sub LoopThroughFiles()
Dim firstEmptyRow As Long
Dim SourceFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook, attachmentWorkSheet As Worksheet
Dim copyRng As Range
Dim header As Range
SourceFolder = "C:\Users\x0514\Desktop\test\"
StrFile = Dir(SourceFolder & "*.xlsx")
Do While Len(StrFile) > 0
Debug.Print StrFile
Set attachmentWorkBook = Workbooks.Open(Filename:=SourceFolder & StrFile)
For Each attachmentWorkSheet In attachmentWorkBook.Worksheets
With ThisWorkbook.Worksheets(attachmentWorkSheet.Name)
'#firsEmptyRow returns the first empty row in column B
firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
'#paste file name to Column A
.Range("A" & firstEmptyRow) = StrFile
'#paste data in column B
Set copyRng = attachmentWorkSheet.Range("A1:CA4")
.Range("B" & firstEmptyRow).Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
End With
Next
attachmentWorkBook.Close SaveChanges:=False
StrFile = Dir
Loop
End Sub
推荐阅读
- javascript - 如何在自定义 javascript 组件上设置背景图像?
- verilog - 输入的Verilog波形相同,但输出不同
- windows - windows docker compose 绑定到特定端点的错误
- python - 我没有得到输出或错误只是处理很长时间
- java - 如何从 BASE64 转换为 ZPL 代码(斑马打印)?
- docker - 有什么好的建议可以实现拒绝主机进入容器的目标吗?
- python - 如何在 Dash Web 应用程序中使用“dash.properties.Synced”?| Python
- json - SwiftUI 从 api.city.bik 获取 JSON API 数据
- javascript - 如何从 Azure Maps Route 计算遍历的状态
- python - 将多变量函数应用于 DataFrame 的列