我在一个名为＆＃39; inputs＆＃39;的文件夹中有一组文件。每个文件包含几个以完全相同的方式布局的工作表，但包含不同的值。每个文件还有一个摘要表，列出A列中的所有工作表名称。
我需要
- 依次打开每个文件 - 将每张纸上的值从另一本书中删除，我将其命名为“整合者”。 ＆安培;根据这些值计算合并工作表。 然后将结果复制并粘贴到输出文件中并保存。 - 我需要为书中的每个工作表执行此操作，然后对文件夹中的每个文件执行此操作。
因此，我的代码包含一个循环（遍历每个工作表），在另一个循环中（遍历每个文件）。
问题是，如果文件中的工作表名称相同（即使文件名不同），我的代码也会运行并生成正确的输出。
但是，如果每个文件中的工作表名称不同，则在我的文件＆＃39;的第二次迭代中循环，代码被中断，在文件名y中找不到工作表名称x（此实例中的文件名y与第一次迭代相比没有变化）。
如果您能提供帮助，请提前致谢！ ：）
这是我的代码：
Sub FileExtractor()
'SET KEY VARIABLES
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
Dim MyPathOutput As String
Dim i As Long
Dim LastRow As Long
Dim rngi As Range
Dim strx As String
Dim StrLen1 As Integer
Dim StrLen2 As Integer
calcsetting = Application.Calculation
'DEFINE FILE LOCATIONS
MyPath = ThisWorkbook.Path
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\Inputs\"
Else
MyPath = MyPath & "Inputs\"
End If
' Change this to the path\folder location of your output file.
MyPathOutput = ThisWorkbook.Path
' If there are no Excel files in the responses folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'define the name of the workbook that is running the macro
Set masterwks = ThisWorkbook
'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO
'set row number where data will start to be pasted
cnum = 1
rnum = 1
' Loop through all files in the myFiles array.
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))
If Not mybook Is Nothing Then
On Error Resume Next
masterwks.Worksheets("Consolidator").Activate
'update consolidator with new input file name
newname = "[" & mybook.Name & "]"
With masterwks.Worksheets("Consolidator")
Currentname = .Range("filename")
.Cells.Replace What:=Currentname, Replacement:= _
newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
LastRow = mybook.Sheets("summary").Range("A:A").Find("*", searchdirection:=xlPrevious).Row
For i = 4 To LastRow
Set rngi = mybook.Sheets("summary").Range("A" & i)
StrLen1 = Len(rngi.Value)
StrLen2 = StrLen1 - 1
strx = Trim(Left(rngi.Value, StrLen2))
newname2 = strx
With masterwks.Worksheets("Consolidator")
Currentname2 = .Range("sheetname")
.Cells.Replace What:=Currentname2, Replacement:= _
newname2, LookAt:=xlPart, SearchOrder:=xlByColumns, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange")
Calculate
'CREATE OUTPUT FILE
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
With BaseWks
Sheets(1).Select
Cells(1, 1).Select
End With
'PASTE FILE DATA
' Set the destination range to A
Set destrange = BaseWks.Range("A" & rnum)
sourceRange.Copy
destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False
destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False
BaseWks.Columns.AutoFit
BaseWks.SaveAs Filename:=MyPathOutput & "\" & masterwks.Sheets("consolidator").Range("sheetname") & " - " & mybook.Name
Next i
End If
mybook.Close savechanges:=False
Next FNum
End If
Application.Calculation = calcsetting
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox "Ta da!!"
Application.Calculation = calcsetting
End Sub
答案 0 :(得分：0)
解决方案：
找到解决我问题的方法......
在替换sheetname之前更换我的整合器表中的文件名适用于第一次迭代但不适用于此后，因为当excel替换每个单独单元格中的文件名时，它会查找已经在单元格中的工作表名称（有时这样地址不存在。）
因此我改变了我的代码以同时替换文件名和工作表名称，这解决了这个问题。谢谢大家:)
Sub FileExtractor()
'SET KEY VARIABLES
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
Dim MyPathOutput As String
Dim StrLen1 As Integer
Dim StrLen2 As Integer
Dim ws As Worksheet
Dim bookname As String
Dim BaseName As String
calcsetting = Application.Calculation
Application.AskToUpdateLinks = False
'DEFINE FILE LOCATIONS
MyPath = ThisWorkbook.Path
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\Inputs\"
Else
MyPath = MyPath & "Inputs\"
End If
' Change this to the path\folder location of your output file.
MyPathOutput = ThisWorkbook.Path
If Right(MyPathOutput, 1) <> "\" Then
MyPathOutput = MyPathOutput & "\Outputs\"
Else
MyPath = MyPathOutput & "Outputs\"
End If
' If there are Excel files in the outputs folder, exit.
FilesInPath = Dir(MyPathOutput & "*.xl*")
If FilesInPath <> "" Then
MsgBox "There are already files in the output folder."
Exit Sub
End If
' If there are no Excel files in the responses folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found in inputs folder."
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'define the name of the workbook that is running the macro
Set masterwks = ThisWorkbook
'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO
'set row number where data will start to be pasted
cnum = 1
rnum = 1
' Loop through all files in the myFiles array.
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))
If Not mybook Is Nothing Then
On Error Resume Next
masterwks.Worksheets("Consolidator").Activate
For Each ws In mybook.Worksheets
If ws.Name <> "Summary" Then
ws.Select
'update consolidator with new input file name
newname = "[" & mybook.Name & "]" & ws.Name
With masterwks.Worksheets("Consolidator")
Currentname = .Range("filename")
.Cells.Replace What:=Currentname, Replacement:= _
newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange")
Calculate
'CREATE OUTPUT FILE
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'PASTE FILE DATA
' Set the destination range to A
Set destrange = BaseWks.Range("A" & rnum)
sourceRange.Copy
destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False
destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False
BaseWks.Columns.AutoFit
bookname = mybook.Name
StrLen1 = Len(bookname)
StrLen2 = StrLen1 - 5
BaseName = Trim(Left(bookname, StrLen2))
BaseWks.SaveAs Filename:=MyPathOutput & "\" & BaseName & " - " & masterwks.Sheets("consolidator").Range("sheetname") & ".xlsx"
ActiveWorkbook.Close
End If
Next ws
End If
mybook.Close savechanges:=False
Next FNum
End If
Application.Calculation = calcsetting
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox "Ta da!!"
Application.Calculation = calcsetting
End Sub