创建一个新作品 sheet 并仅在 sheet 不存在该名称的情况下为其命名

Question

我不确定我是否最有效地执行此操作，但我正在尝试将产品复制到新创建的 sheet 中（如果它们是同一产品）。

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

目前，我的程序是运行通过双循环。第一个循环遍历第一个 sheet 中的每一行，第二个循环遍历 sheet 个名称。

我运行遇到的问题是第一个循环：代码为列表中的第一个产品创建了一个新的 sheet，这很好。但是列表中的下一个产品是同一个产品，所以它应该放在新创建的 sheet 中。但是，我的代码创建了另一个新 sheet，尝试在列表中的下一个产品之后重命名它，然后出现错误并显示

"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

快速回答：与其遍历现有的 sheet，不如看看你想要的 sheet 是否存在，然后直接去那里。像这样：

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 2

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

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

Answer 3

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

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

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

创建一个新作品 sheet 并仅在 sheet 不存在该名称的情况下为其命名

Creating a new worksheet and naming it only if a sheet by that name does not exist already

excel

vba

excel-2013