![](/img/trans.png)
[英]Loop folder and check if Excel file name ends with worksheet name, then copy worksheet
[英]Excel VBA loop folder and check if Excel file name is equal to worksheet
我需要一些启示。 我正在尝试将Excel文件的文件夹与Excel工作簿中的某些工作表匹配。 到目前为止,我已经能够读取这些Excel文件名和相应的工作表并将其复制到我的工作簿的sheet1
B1
中。 之后,我为每个文件创建一个工作表。
我希望该宏继续并将目录中的每个文件与工作簿中的工作表进行比较。 如果工作簿中的工作表名称等于文件名,则复制文件内容(只有这些文件中的sheet1
才有数据)。
这是我到目前为止的内容:
Sub readme()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Application.ScreenUpdating = False
directory = "D:\Claro Chile\Report_sem_formulas\"
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
i = i + 1
j = 2
Cells(i, 1) = fileName
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
Workbooks("Report Status v1.xlsm").Worksheets(1).Cells(i, j).Value = sheet.Name
j = j + 1
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Call create_sheets_starting_from_B1
End Sub
Sub create_sheets_starting_from_B1()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("B1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new worksheet
Next MyCell
Sheets("Summary").Move Before:=Sheets(1)
End Sub
未经测试!
但您可能需要以下内容吗:
Sub sheetCompare()
Dim i As Integer
Dim mDirs As String
Dim path As String
Dim OutFile As Variant, SrcFile As Variant
Dim file As Variant
OutFile = ActiveWorkbook.Name
mDirs = "c:\" 'your dir here
file = Dir(mDirs)
While (file <> "")
path = mDirs + file
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
For i = 1 To Workbooks(OutFile).Sheets.Count
If file = Workbooks(OutFile).Sheets(i).Name Then
'copy logic
End If
Next i
Workbooks(file).Close (False)
file = Dir
Wend
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.