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

Question

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

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

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

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

"You can't name the sheet after a sheet named the same thing".

现在这是一个 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