Question

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

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

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

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

＆＃34;您无法在名称相同且＃34;的工作表之后命名该工作表。

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

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

CODE：

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

仅当已经不存在该名称的工作表时，才创建新工作表并对其进行命名

3 个答案: