Modifiying working code

[tenda]

I'm using the following code that exists in this page: https://www.mrexcel.com/forum/excel...into-multiple-worksheets-based-column-11.html created by mirabeau.

[COLOR=#333333]Sub columntosheets() [/COLOR]
Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate 
[COLOR=#333333][COLOR=#333333]End Sub[/COLOR][/COLOR]

The code works fine for distributing data from one main data sheet to several sheets after creating them using ColA criterion. What is needed to be modified in the code:
1. to check first if the data sheets already exist before creating them, and
2. if they exist only new data from the main data sheet should be appended to the last row of data in each sheet.

Applying these modifications will enrich the code instead of using it only for one time and then manually appending new data rows to their designated sheets.

Can I get some expert assistance with this request please?

very much appreciated.

 

[Yongle]

Untested but you could try this in a copy of your workbook

Replace

        Sheets.Add.Name = a(p, 1)
        .Cells(1).Resize(, cls).Copy Cells(1)
        .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)

With

        If Not Evaluate("ISREF('" & a(p,1) & "'!A1)") Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
        End If
        Sheets(a(p, 1)).Activate
        .Cells(p, 1).Resize(i - p, cls).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)

 

[tenda]

Thank you Yongle for your reply. As I tried your modification, it did actually not work as expected. It was halted for runtime error "The item with the specified name wasn't found" at line 29. Amazingly, a new sheet is added with the content of the main page.
What is needed, is that the code before adding a new page:
1. To search for it, if it exists, it appends whatever data from the main page (which is always updated) to the data that already exist in that found sheet.
2. If the sheet does not exist, it creates one and appends its specific data from the main page.

Once again, thank you very much for your invaluable assistance.

 

[Yongle]

runtime error "The item with the specified name wasn't found" at line 29

which line is that?

 

[tenda]

Sub columntosheets()
Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "R" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh


Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
        If Not Evaluate("ISREF('" & a(p, 1) & "'!A1)") Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
        End If
        Sheets(a(p, 1)).Activate
        .Cells(p, 1).Resize(i - p, cls).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub

Line 29 of this script: Sheets(a(p, 1)).Activate

Thanks very much

 

[Yongle]

it creates one and appends its specific data from the main page

What was the name was given to this sheet?

 

[tenda]

A default name was given with a number that incremented by one every time the code is run, so it was 'Sheet39', then Sheet40 ..etc, which I deleted of course.
Thanks very much ..

 

[Yongle]

I wonder why is the sheet not being renamed? - the naming is your original code

Let's try converting the relevent values to a string to reduce risk of mismatch

        If Not Evaluate("ISREF('" & [COLOR=#ff0000][SIZE=4]CStr([/SIZE][/COLOR]a(p, 1)[SIZE=4][COLOR=#ff0000])[/COLOR][/SIZE] & "'!A1)") Then
            Sheets.Add.Name = [COLOR=#ff0000][SIZE=4]CStr([/SIZE][/COLOR]a(p, 1)[SIZE=4][COLOR=#ff0000])[/COLOR][/SIZE]
            .Cells(1).Resize(, cls).Copy Cells(1)
        End If
        Sheets([COLOR=#ff0000][SIZE=4]CStr([/SIZE][/COLOR]a(p, 1)[SIZE=4][COLOR=#ff0000])[/COLOR][/SIZE]).Activate
        .Cells(p, 1).Resize(i - p, cls).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)

 

[tenda]

Definitely yes Yongle. You did it. Your modification did the desired result 100%. I tested the full script on the real data: first time run it created the new sheets and added data to them, and second and third time run it did append new data to existing data, and also recreated the new sheets (which I deleted for testing) and copied their designated data.

So this issue is fully resolved by you Yongle, and I do thank you very much for your effort, knowledge and time spend on this problem. You do have a great value added to this world.
All the best.