Question

我正在使用VBA代码循环浏览目录中的excel文件，并从一个工作表中提取信息并粘贴到新创建的工作表中。我也在源文件的一个单元格中命名我的新工作表（在我的目标文件中）。

我的代码适用于第一个循环，但在第二个循环中失败/停止（VBA指向Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname行中的错误。我需要遍历这些文件中的75个而且我不确定会发生什么因为它适用于第一个文件。

非常感谢你的帮助！

Sub AddSummaryTables()

Dim Spath, Filename, Sheetname As String
Dim Source, Dest As Workbook
Dim WS As Worksheet
Set Dest = ThisWorkbook

Spath = InputBox("Enter File Source Path") & "\"
Filename = Dir(Spath & "*.xls*")

Do While Filename <> ""

Set Source = Workbooks.Open(Spath & Filename)
Sheetname = Source.Sheets("Summary").Range("B2").Text
MsgBox Sheetname
Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname
Source.Sheets("Summary").Range("A1:R150").Copy
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteValues
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteFormats

Dest.Worksheets(Sheetname).Range("A1:R150").WrapText = False
Dest.Worksheets(Sheetname).Rows.AutoFit
Dest.Worksheets(Sheetname).Columns.AutoFit
Source.Close SaveChanges:=False
Dest.Save

Filename = Dir()
Loop

End Sub

Answer 1

根据Comintern和Wyatt的建议，您可以尝试以下

Option Explicit

Sub AddSummaryTables()

Dim sPath As String, fileName As String
Dim sourceWb As Workbook, destWb As Workbook
Dim sourceWs As Worksheet, destWs As Worksheet

Set destWb = ThisWorkbook

sPath = InputBox("Enter File Source Path") & "\"
fileName = Dir(sPath & "*.xls*")

Do While fileName <> ""

    Set sourceWb = Workbooks.Open(sPath & fileName)
    Set sourceWs = GetWorksheet(sourceWb, "Summary")
    If Not sourceWs Is Nothing Then
        Set destWs = SetWorksheet(destWb, sourceWs.Range("B2").Text)

        sourceWs.Range("A1:R150").Copy
        With destWs
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
            .UsedRange.WrapText = False
            .Rows.AutoFit
            .Columns.AutoFit
        End With

        sourceWb.Close SaveChanges:=False

        destWb.Save

    End If

    fileName = Dir()
Loop

End Sub


Function GetWorksheet(wb As Workbook, sheetName As String) As Worksheet

On Error Resume Next
Set GetWorksheet = wb.Worksheets(sheetName)
On Error GoTo 0

End Function


Function SetWorksheet(wb As Workbook, sheetName As String) As Worksheet
Dim i As Integer

Do While Not GetWorksheet(wb, sheetName & IIf(i = 0, "", "-" & i)) Is Nothing
    i = i + 1
Loop

With wb
    .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = sheetName & IIf(i = 0, "", "-" & Format(i, "000"))
    Set SetWorksheet = .ActiveSheet
End With

End Function

确保

任何已打开的工作簿都有“摘要”工作表
您在目标工作簿中命名工作表，例如没有重复项：如果您碰巧说三个名为“Sheet5”的工作表，那么您的目标工作簿将添加工作表“Sheet5”，“Sheet5-001”和“Sheet5” -002" 。

Answer 2

您的问题可能是，当您从第二个工作簿添加工作表时，它与第一个工作簿中的工作表具有相同的名称。您可以检查工作表是否存在并为其添加数字。以下帖子可能有所帮助。

Test or check if sheet exists

Excel工作表名称错误

2 个答案: