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

Question

I am not sure if I am performing this operation the most effectively, but I am attempting to copy products into newly created sheets if they are the same product.

For example if there are 4 products that are "Apples" and two that are "Oranges". Then I would like to create a new sheet for each product, rename the new sheet after said product, and place each row containing said product into each new sheet.

Currently, my program is running through a double loop. The first loop runs through each row in the first sheet, and the second loops through the sheet names.

The problem I am running into is with the first loop: the code creates a new sheet for the first product in the list, which is fine. But the next product in the list is the same product, so it should be placed into the newly-created sheet. However, my code creates another new sheet, attempts to rename it after the product next in the list, and then errors and says

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

Now that is a Catch-22, because my if statement should catch it, but it doesn't.

I am running this is an outside workbook, after the program runs, I will save it under a different file name, so I'd prefer not to paste the date into the macro file and just keep it as a separate file.

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

You need 1 loop to go through all rows of the sheet you want to scan. In this loop check if a sheet with the product name exists. If it exists find the next free row in it and past your data. If it does not exists add a sheet with that product name and paste in row 1. Next Loop. That's all the magic. — Pᴇʜ, Jun 18 '18 at 15:24

score 2 · Accepted Answer · answered Jun 18 '18 at 15:40

You need 1 loop to go through all rows of the sheet you want to scan. In this loop check if a sheet with the product name exists. If it exists find the next free row in it and past your data. If it does not exists add a sheet with that product name and paste in row 1.

Note that you can only use the left 31 characters of the product name for your worksheet names. Worksheet names have a limit.

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

score 0 · Answer 2 · answered Jun 18 '18 at 15:27

Quick answer: Instead of looping through the existing sheets, you should see if the sheet you want exists, then just go there. Something like this:

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

For the WorksheetExists function, see Test or check if sheet exists

Eliot K · Answer 3 · 2018-06-18T15:57:53.993

As others have noted, you need to check all sheet names before you take action, but I recommend adding a function that stores the names of the worksheets into a dictionary to speed that process up. I did my best to update your code with this accordingly.

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

I am a bit confused as to what this line does? `Set tmpSht = create_sheet_by_name_if_missing(.Cells(y, 2).Value, sht_dict, tempWB)` Is this supposed to be `sheet.add` — A Cohen, Jun 18 '18 at 15:36
@ACohen: With good reason since the answer is 'nothing'. I created a function to create the sheet, then reread his code and realized his code did that and more, so I removed the function without removing it from his code. I've updated my answer, now. — Eliot K, Jun 18 '18 at 15:59

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

3 Answers3