Adjusting code divide data of table into tables in each sheet [Solved]

Report
Posts
58
Registration date
Thursday July 18, 2019
Status
Member
Last seen
October 17, 2020
-
Posts
58
Registration date
Thursday July 18, 2019
Status
Member
Last seen
October 17, 2020
-
hi,
my code really works but the problem when i add a new data it doesn't copy to the multiple sheets because the first time runs code it creates sheets and when i run code again it can't create the same names of sheets what i would after run code the first time and add a new data should transfer data to relevant sheets created automatically updating and if add a new data not relevant created sheets then it create a new sheets
create name of sheets and data based on column b in the main sheet


this is my images 1,2,3






Sub devide_and_copy()

Dim lastrow As Long, orig As Worksheet, tmp As Worksheet, uval As Integer, x As Integer, code As String, sname As String, firstvis As Integer

Set orig = ActiveSheet
Sheets.Add
ActiveSheet.Name = "tmp"
Set tmp = ActiveSheet

orig.Activate
lastrow = Cells(Rows.Count, "B").End(xlUp).Row

orig.Range("B1:B" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=tmp.Range("B1"), _
Unique:=True

uval = tmp.Cells(Rows.Count, "B").End(xlUp).Row

For x = 2 To uval
code = tmp.Cells(x, 2).Value
orig.Range("A1").AutoFilter _
Field:=2, _
Criteria1:=code
firstvis = 2

findfirst:
If orig.Rows(firstvis).Hidden = True Then
firstvis = firstvis + 1
GoTo findfirst
End If

sname = orig.Cells(firstvis, 2).Value
orig.Copy after:=Worksheets(Sheets.Count)
ActiveSheet.Name = sname
Next x

Application.DisplayAlerts = False
tmp.Delete
Application.DisplayAlerts = True

orig.Activate
orig.ShowAllData

End Sub

4 replies

Posts
2669
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 15, 2020
446
Hi Abdel,

To check if a sheets exists, I like to add a user defined function, which you will find below your code. Then I added code line 34 and 37, to see if a new sheet needs to be added.

Sub devide_and_copy()

Dim lastrow As Long, orig As Worksheet, tmp As Worksheet, uval As Integer, x As Integer, code As String, sname As String, firstvis As Integer

Set orig = ActiveSheet
Sheets.Add
ActiveSheet.Name = "tmp"
Set tmp = ActiveSheet

orig.Activate
lastrow = Cells(Rows.Count, "B").End(xlUp).Row

orig.Range("B1:B" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=tmp.Range("B1"), _
Unique:=True

uval = tmp.Cells(Rows.Count, "B").End(xlUp).Row

For x = 2 To uval
    code = tmp.Cells(x, 2).Value
    orig.Range("A1").AutoFilter _
    Field:=2, _
    Criteria1:=code
    firstvis = 2
    
findfirst:
    If orig.Rows(firstvis).Hidden = True Then
        firstvis = firstvis + 1
        GoTo findfirst
    End If
    
    sname = orig.Cells(firstvis, 2).Value
    If Not SheetExists(sname) Then
        orig.Copy after:=Worksheets(Sheets.Count)
        ActiveSheet.Name = sname
    End If
Next x

Application.DisplayAlerts = False
tmp.Delete
Application.DisplayAlerts = True

orig.Activate
orig.ShowAllData

End Sub

Function SheetExists(ByVal SheetName As String) As Boolean

On Error Resume Next
SheetExists = (Sheets(SheetName).Name <> vbNullString)
On Error GoTo 0

End Function


Best regards,
Trowa
1
Thank you

Glad we were able to help! Love us? Write us a review! Rate CCM

CCM 2942 users have said thank you to us this month

Posts
58
Registration date
Thursday July 18, 2019
Status
Member
Last seen
October 17, 2020

hi,
Trowad , actually it doesn't add a new data to specific sheet and i would when transfer data it shows the total like this


Posts
2669
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 15, 2020
446
Hi Abdel,

It's quite the challenge to understand what you mean sometimes :).

How about this scenario:
Use column G on your main sheet to check wether data has been copied or not.
The code will loop through your main sheet column B.
When column G is empty (so hasn't been copied yet), check to see if sheet exists.
When it doesn't: Create sheet, name sheet, add header, paste the values and add an "x" to column G of the main sheet.
When it does: Paste the values and add an "x" to column G of the main sheet.
When column G has on "x" in it, the row is skipped.

Here is the code for that:
Sub RunMe()
Headr = Range("A1:F1").Value

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    If cell.Offset(0, 5) <> "x" Then
        If Not SheetExists(cell.Value) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = cell.Value
            Range("A1:F1") = Headr
        End If
        
        cell.EntireRow.Copy Sheets(cell.Value).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        cell.Offset(0, 5) = "x"
    End If
Next cell
End Sub

Function SheetExists(ByVal SheetName As String) As Boolean

On Error Resume Next
SheetExists = (Sheets(SheetName).Name <> vbNullString)
On Error GoTo 0

End Function


Best regards,
Trowa
Posts
58
Registration date
Thursday July 18, 2019
Status
Member
Last seen
October 17, 2020

this is not good it gives error about column date i prefer your adjusting earlier , actually i'm surprising you find difficultly understand me , your adjusting is so good but the problem when i add a new data in sheet1 it supposes to add this data to specific data based on column b but it doesn't happen
for instance i would take about brand AA as example
image 1 the first time filling data




image 2 when run macro it create names sheets based on column b and transfer data from sheet1




image 3 add a new data and highlight by yellow color




image 4 it supposes the final result after add a new data and sum the values highlight by yellow color


i'm talking about the first adjusting code
i hope this help to understand what i'm looking for
Posts
2669
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 15, 2020
446
Hi Abdel,

Alright, new strategy then. When sheet already exists, the sheet will be deleted, so a new sheet can always be created. I also added the Total row at the end of each added sheet.

My result looks exactly like your screenshots now, except for the colored rows, but I believe that was just to point out what you meant.


Here is the code:
Sub devide_and_copy()
Dim lastrow As Long, orig As Worksheet, tmp As Worksheet, uval As Integer, x As Integer, code As String, sname As String, firstvis As Integer

Application.DisplayAlerts = False

Set orig = ActiveSheet
Sheets.Add
ActiveSheet.Name = "tmp"
Set tmp = ActiveSheet

orig.Activate
lastrow = Cells(Rows.Count, "B").End(xlUp).Row

orig.Range("B1:B" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=tmp.Range("B1"), _
Unique:=True

uval = tmp.Cells(Rows.Count, "B").End(xlUp).Row

For x = 2 To uval
    code = tmp.Cells(x, 2).Value
    orig.Range("A1").AutoFilter _
    Field:=2, _
    Criteria1:=code
    firstvis = 2
    
findfirst:
    If orig.Rows(firstvis).Hidden = True Then
        firstvis = firstvis + 1
        GoTo findfirst
    End If
    
    sname = orig.Cells(firstvis, 2).Value
    If SheetExists(sname) Then
        Sheets(sname).Delete
    End If
    
    orig.Copy after:=Worksheets(Sheets.Count)
    ActiveSheet.Name = sname
    Range("A" & lastrow + 1).Value = "TOTAL"
    Range("F" & lastrow + 1).Value = WorksheetFunction.Sum(Range("F2:F" & lastrow).SpecialCells(xlCellTypeVisible))
Next x

tmp.Delete
Application.DisplayAlerts = True

orig.Activate
orig.ShowAllData

End Sub

Function SheetExists(ByVal SheetName As String) As Boolean

On Error Resume Next
SheetExists = (Sheets(SheetName).Name <> vbNullString)
On Error GoTo 0

End Function


Best regards,
Trowa
Posts
58
Registration date
Thursday July 18, 2019
Status
Member
Last seen
October 17, 2020

awesome , now the code works without any problem thanks Trowa for your assistance