仅当该名称的工作表不存在时才创建新工作表并为其命名

Question

我不确定我是否最有效地执行此操作，但如果它们是相同的产品，我会尝试将产品复制到新创建的工作表中。

例如，如果有 4 个产品是 "Apples"，两个是 "Oranges"。然后我想为每个产品创建一个新工作表，以所述产品重命名新工作表，并将包含所述产品的每一行放入每个新工作表中。

目前，我的程序正在通过双循环运行。第一个循环遍历第一个工作表中的每一行，第二个循环遍历工作表名称。

我遇到的问题是第一个循环：代码为列表中的第一个产品创建了一个新工作表，这很好。但是列表中的下一个产品是相同的产品，因此应该将其放入新创建的工作表中。但是，我的代码创建了另一个新工作表，尝试在列表中的下一个产品之后重命名它，然后出错并说

“您不能以同名工作表命名工作表”。

现在这是一个 Catch-22，因为我的 if 语句应该捕获它，但它没有。

我正在运行这是一个外部工作簿，程序运行后，我会将其保存为不同的文件名，因此我不希望将日期粘贴到宏文件中，而是将其保存为单独的文件。

代码：

Dim fd As FileDialog
Dim tempWB As Workbook
Dim i As Integer

Dim rwCnt As Long
Dim rngSrt As Range
Dim shRwCnt As Long

Set fd = Application.FileDialog(msoFileDialogFilePicker)

For i = 1 To fd.SelectedItems.Count

    Set tempWB = Workbooks.Open(fd.SelectedItems(i))

    With tempWB.Worksheets(1)
        For y = 3 To rwCnt
            For Z = 1 To tempWB.Sheets.Count
                If .Cells(y, 2).Value = tempWB.Sheets(Z).Name Then
                    .Rows(y).Copy
                    shRwCnt = tempWB.Worksheets(Z).Cells(Rows.Count, 1).End(xlUp).Row
                    tempWB.Worksheets(Sheets.Count).Range("A" & shRwCnt).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                ElseIf tempWB.Sheets(Z).Name <> .Range("B" & y).Value Then
                    If Z = tempWB.Sheets.Count Then
                        .Range("A1:AQ2").Copy
                        tempWB.Worksheets.Add after:=tempWB.Worksheets(Sheets.Count)
                        tempWB.Worksheets(Sheets.Count).Name = .Cells(y, 2).Value
                        tempWB.Worksheets(Sheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        .Rows(y).Copy
                        tempWB.Worksheets(Sheets.Count).Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                End If
            Next Z
        Next y
    End With

Next i

Answer 1

您需要 1 个循环来遍历要扫描的工作表的所有行。在此循环中，检查是否存在具有产品名称的工作表。如果存在，则在其中找到下一个空闲行并过去您的数据。如果不存在，请添加具有该产品名称的工作表并粘贴到第 1 行。

请注意，您的工作表名称只能使用产品名称的左侧 31 个字符。工作表名称有限制。

Dim WsDest As Worksheet

For i = 1 To fd.SelectedItems.Count

    Set tempWB = Workbooks.Open(fd.SelectedItems(i))
    With tempWB.Worksheets(1)
        For y = 3 To rwCnt
            Set WsDest = Nothing
            On Error Resume Next 'next line throws an error if the ws does not exist so hide errors
            Set WsDest = Worksheets(Left$(.Cells(y, 2).Value, 31)) 'worksheet names are limited to 31 characters
            On Error GoTo 0 're-activate error reporting

            If WsDest Is Nothing Then 'if ws does not exist
                'add this sheet name it and copy/paste
                Set WsDest = Worksheets.Add
                WsDest.Name = Left$(.Cells(y, 2).Value, 31) 'worksheet names are limited to 31 characters

                .Rows(y).Copy
                WsDest.Cells(1, 1).Paste
            Else
                'find last used row and copy/paste
                shRwCnt = WsDest.Cells(WsDest.Rows.Count, 1).End(xlUp).Row

                .Rows(y).Copy
                WsDest.Cells(shRwCnt + 1, 1).Paste
            End If

        Next y
    End With
Next i

Answer 2

快速回答：您应该查看您想要的工作表是否存在，而不是循环遍历现有工作表，然后前往那里。像这样的：

For i = 1 To fd.SelectedItems.Count
    If WorksheetExists(.Cells(y, 2).Value) Then' 
         'Copy the data into the existing sheet
    end if
Next i

有关 WorksheetExists 函数，请参阅Test or check if sheet exists

Answer 3

正如其他人所指出的，您需要在采取行动之前检查所有工作表名称，但我建议添加一个将工作表名称存储到字典中的函数以加快该过程。我已尽力相应地更新您的代码。

Function get_worksheet_names() As Object

    Dim d As Object _
      , sht As Worksheet
    Set d = CreateObject("Scripting.Dictionary")
    For Each sht In ThisWorkbook.Sheets
        d.Add sht.Name, sht.Index
    Next sht

    Set get_worksheet_names = d

End Function

Sub update_workbook_sheets()

    Dim fd As FileDialog
    Dim tempWB As Workbook
    Dim i As Integer
    Dim sht_dict As Object
    Dim tmpSht As Worksheet

    Dim rwCnt As Long
    Dim rngSrt As Range
    Dim shRwCnt As Long

    Set sht_dict = get_worksheet_names()    'get dictionary of sheets
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    For i = 1 To fd.SelectedItems.Count

        Set tempWB = Workbooks.Open(fd.SelectedItems(i))

        With tempWB.Worksheets(1)
            For y = 3 To rwCnt

                If sht_dict.Exists(.Cells(y, 2).Value) Then 'If sheet exists
                    .Rows(y).Copy
                    shRwCnt = tempWB.Worksheets(Z).Cells(Rows.Count, 1).End(xlUp).Row
                    tempWB.Worksheets(Sheets.Count).Range("A" & shRwCnt).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Else    'if sheet does not exist
                    .Range("A1:AQ2").Copy
                    tempWB.Worksheets.Add after:=tempWB.Worksheets(Sheets.Count)
                    tempWB.Worksheets(Sheets.Count).Name = .Cells(y, 2).Value
                    tempWB.Worksheets(Sheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Rows(y).Copy
                    tempWB.Worksheets(Sheets.Count).Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Set sht_dict = get_worksheet_names()
                End If
            Next y
        End With

    Next i

End Sub