Previous Topic Next Topic

Adjusting code divide data of table into tables in each sheet

Solved/Closed
abdelfatah_0230 Posts 73 Registration date Thursday July 18, 2019 Status Member Last seen July 23, 2022 - May 24, 2020 at 01:15 PM
abdelfatah_0230 Posts 73 Registration date Thursday July 18, 2019 Status Member Last seen July 23, 2022 - May 28, 2020 at 03:36 PM
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

Related:

4 responses

Answer 1 / 4
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 555
May 25, 2020 at 11:54 AM
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
abdelfatah_0230 Posts 73 Registration date Thursday July 18, 2019 Status Member Last seen July 23, 2022
Updated on May 25, 2020 at 04:32 PM
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


Answer 2 / 4
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 555
May 26, 2020 at 11:59 AM
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
abdelfatah_0230 Posts 73 Registration date Thursday July 18, 2019 Status Member Last seen July 23, 2022
Updated on May 26, 2020 at 03:24 PM
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
Answer 3 / 4
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 555
May 28, 2020 at 12:17 PM
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
Answer 4 / 4
abdelfatah_0230 Posts 73 Registration date Thursday July 18, 2019 Status Member Last seen July 23, 2022
May 28, 2020 at 03:36 PM
awesome , now the code works without any problem thanks Trowa for your assistance