macro for dividing master sheet to new sheets based on column

[tsurvey]

This is for Excel 2010. I have a workbook with the first tab "Master". I want to keep this tab for data entry but have separate tabs based on column G - "OwnerType" as the category, my first row is a header. I found a macro that looks like it might work for most of what I do but it does not appear to create the header row and it gives me a run error at:
If ws Is Nothing Then
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = category.Value
Sheets("Master").Rows(1).Copy Cells(1, 1)

I am not a VBA programmer and only have limited experience in other languages so any help is appreciated. The steps I want to accomplish:

1. find the first unique category, if a sheet does not exist, create one, add the header row (row 1), and then add all of the rows that also have that category.
2. repeat for the rest of the table
3. if a category already has an existing sheet, check each row to see if it has already been entered. Column A has a unique ID number (can be considered a primary key) that can be used for checking duplicates.
4. Add any new rows to the appropriate sheet.

The Master sheet will be updated regularly so this is something that will be run from time to time. Here is the macro I copied from this site.
Sub AddSheet()
Application.ScreenUpdating = False
Dim bottomG As Long
bottomG = Sheets("Master").Range("G" & Rows.Count).End(xlUp).Row
Dim category As Range
Dim ws As Worksheet
Sheets("Master").Range("G2:G" & bottomG).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
("G2:G" & bottomG), Unique:=True
Set rnguniques = Sheets("Master").Range("G3:G" & bottomG).SpecialCells(xlCellTypeVisible)
If Sheets("Master").FilterMode Then Sheets("Master").ShowAllData
For Each category In rnguniques
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(category.Value)
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = category.Value
Sheets("Master").Rows(1).Copy Cells(1, 1)
End If
Next category
For Each category In rnguniques
Sheets("Master").Range("G2:G" & bottomG).AutoFilter Field:=1, Criteria1:=category
Sheets("Master").Range("G3:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
If Sheets("Master").FilterMode Then Sheets("Master").ShowAllData
Next category
Application.ScreenUpdating = True
End Sub

Any help is greatly appreciated.

 

[JLGWhiz]

See if this helps

Sub AddSheet()
 Application.ScreenUpdating = False
 Dim bottomG As Long
 bottomG = Sheets("Master").Range("G" & Rows.Count).End(xlUp).Row
 Dim category As Range
 Dim ws As Worksheet
 Sheets("Master").Range("G2:G" & bottomG).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
 ("G2:G" & bottomG), Unique:=True
 Set rnguniques = Sheets("Master").Range("G3:G" & bottomG).SpecialCells(xlCellTypeVisible)
 If Sheets("Master").FilterMode Then Sheets("Master").ShowAllData
     For Each category In rnguniques
         On Error Resume Next
         Set ws = Worksheets(category.Value)
         If Err.Number = 9 Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = category.Value
            Sheets("Master").Rows(1).Copy ActiveSheet.Cells(1, 1)
        End If
        On Error GoTo 0 
        Sheets("Master").Range("G2:G" & bottomG).AutoFilter Field:=1, Criteria1:=category
        Sheets("Master").Range("G3:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset  (1, 0)
        If Sheets("Master").FilterMode Then Sheets("Master").ShowAllData
      Next category
 Application.ScreenUpdating = True
 End Sub

 

[tsurvey]

Thanks for the quick response. When I run the macro I get a Run-time error '9': subscript out of range
The debug highlights it at:
Sheets("Master").Range("G3:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

 

[dmt32]

Hi,
give code I posted (post #2) here:https://www.mrexcel.com/forum/excel...t-another-based-value-column-first-sheet.html

a try & see if does what you want


Dave

 

[tsurvey]

dmt32 - That did the magic, AWESOME. I just got brownie points from the person trying to manage one of our projects. Wish I could share the beer with you I really like the prompt feature, nice. Is there a way to mark this as the answer?

 

[dmt32]

dmt32 - That did the magic, AWESOME. I just got brownie points from the person trying to manage one of our projects. Wish I could share the beer with you I really like the prompt feature, nice. Is there a way to mark this as the answer?

Hi,
I have seen many requests similar to yours so I developed that code - seems to work for most users & glad helped you with your requirement.
Never know, may get to bump in to each other one day for that beer.

Appreciate the feedback


Dave