Creating a new worksheet for each row, but duplicates should be in same worksheet-CodePudding

I would like to create a new worksheet for every customer in my excel file. The customer number is given in column c, but it is only the first 7 letters that shows the customer number. Therefore I would like if the code named each new worksheet it creates, after the customer number, so that it can check if a customer already has a worksheet, and if it does, the next row in the first worksheet that contains the same customer number should be put into that new worksheet, below what has already been copied into there.

Function SheetExists(SheetName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then Set InWorkbook = ActiveWorkbook
On Error Resume Next
SheetExists = Not InWorkbook.Sheets(SheetName) Is Nothing
On Error GoTo 0

End Function

Sub RowToSheet()
Dim xRow As Long
Dim I As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
ActiveSheet.Name = "Sheet 1"
With ActiveSheet
    xRow = .Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To xRow
         If Not SheetExists(Left(Cells(I, 3), 7)) Then Worksheets.Add(, Sheets(Sheets.Count)).Name = Left(Cells(I, 3), 7)
        .Rows(I).Copy Sheets(Left(Cells(I, 3), 7)).Cells(Sheets(Left(Cells(I, 3), 7)).Cells(Rows.Count, 1).End(xlUp).Row   1, 1)
        Sheets(1).Rows(1).Copy Destination:=Sheets(Left(Cells(I, 3), 7)).Rows(1)
    Next I
End With

CodePudding user response：

Test if the sheet exists before adding a new one. Here's a simple function for checking if a sheet with that name exists:

Function SheetExists(SheetName As String, Optional InWorkbook As Workbook) As Boolean
    If InWorkbook Is Nothing Then Set InWorkbook = ActiveWorkbook
    On Error Resume Next
    SheetExists = Not InWorkbook.Sheets(SheetName) Is Nothing
    On Error GoTo 0
End Function

You would add it to your code like:

Sub RowToSheet()
    Dim xRow As Long
    Dim I As Long
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    ActiveSheet.Name = "Sheet 1"
    With ActiveSheet
        xRow = .Range("A" & Rows.Count).End(xlUp).Row
        For I = 2 To xRow
            If Not SheetExists("Row " & I) Then Worksheets.Add(, Sheets(Sheets.Count)).Name = "Row " & I
            .Rows(I).Copy Sheets("Row " & I).Range("A2")
            Sheets(1).Rows(1).Copy Destination:=Sheets(I).Rows(1)
        Next I
    End With
End Sub

This way the sheet is only created if it did not already exist. The .Copy will overwrite the values on Range("A2") so you will want to change that to dynamically search for the next empty row like:

.Rows(I).Copy Sheets("Row " & I).Cells(Sheets("Row " & I).Cells(Rows.Count, 1).End(xlUp).Row   1, 1)

And your line Sheets(1).Rows(1).Copy Destination:=Sheets(I).Rows(1) is just guessing that the new sheet will be in the same position as the loop index. I suggest correcting that to be:

Sheets(1).Rows(1).Copy Destination:=Sheets("Row " & I).Rows(1)

CodePudding user response：

Use a dictionary to hold the unique customer numbers. Loop through them applying a filter to column C and copy the filtered records to a new sheet/workbook.

Option Explicit

Sub RowToSheet()

    Dim wb As Workbook
    Dim ws As Worksheet, wsNew As Worksheet
    Dim LastRow As Long, i As Long, n As Integer

    Dim dict As Object, key, rng As Range
    Set dict = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet 1")
    LastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    Set rng = ws.Range("A1:P" & LastRow)

    ' build list of unique values from col C
    For i = 2 To LastRow
        key = Trim(Left(ws.Cells(i, "C"), 7))
        If Len(key) > 0 Then dict(key) = 1
    Next

    ' delete any existing sheets
    Application.DisplayAlerts = False
    For Each wsNew In wb.Sheets
       If wsNew.Name <> "Sheet 1" Then
            wsNew.Delete
       End If
    Next
    Application.DisplayAlerts = True
    n = wb.Sheets.Count

    ' create new sheets/workbooks for each unique value
    Application.ScreenUpdating = False
    For Each key In dict.keys

        Set wsNew = wb.Sheets.Add(after:=wb.Sheets(n))
        wsNew.Name = Right(key, 5) ' number with  C:
        n = n   1

        ' filter on col C and copy to new sheet
        rng.AutoFilter 3, Criteria1:=CStr(key) & "*"
        rng.Copy wsNew.Range("A1")
        rng.AutoFilter 3

        ' copy to new workbook
        wsNew.Copy
        ActiveWorkbook.SaveAs wb.Path & "\" & wsNew.Name
        ActiveWorkbook.Close False
    Next
    Application.ScreenUpdating = False
    'ws.AutoFilterMode = False
    
    MsgBox dict.Count & " workbooks created", vbInformation
    
End Sub