Create multiple worksheets in an excel file using strings in one column and auto update such worksheets based on the master sheet.

[mshah23]

I have a master sheet which has multiple data like Date, Item Name, Weight, Price which is updated daily by appending new data below the old data in the same sheet

I wish to automatically prepare multiple sheets based on different items present in the column "Item Name" in the master sheet.
Also each of these sheets prepared should automatically capture the data present in the master sheet to each of these sheets with columns like Date, Weight, Price (and even Name).

 

[mumps]

Try:

Private Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, lastRow As Long, ws As Worksheet, srcWS As Worksheet
    Set srcWS = Sheets("[COLOR="#FF0000"]Master[/COLOR]")
    lastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(Rng.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Rng.Value
            With srcWS
                .Rows(1).Copy Cells(1, 1)
                .Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=Rng.Value
                .Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End With
        End If
    Next Rng
    srcWS.Range("B1").AutoFilter
    Application.ScreenUpdating = True
End Sub

The macro assumes your data is in a sheet named "Master" (in red).

 

[mshah23]

Try:

Private Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, lastRow As Long, ws As Worksheet, srcWS As Worksheet
    Set srcWS = Sheets("[COLOR="#FF0000"]Master[/COLOR]")
    lastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(Rng.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Rng.Value
            With srcWS
                .Rows(1).Copy Cells(1, 1)
                .Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=Rng.Value
                .Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End With
        End If
    Next Rng
    srcWS.Range("B1").AutoFilter
    Application.ScreenUpdating = True
End Sub

The macro assumes your data is in a sheet named "Master" (in red).

Hi.
Your code almost solves 70% of my problem. I could use some more help from your side as whenever I try to run the macro after appending the new data to the master table, it couldn't catch the same in the respective tables. Can you help me with same alongwith taking following under consideration.
1. New data is required to be appended in the respective Item Name table on a daily basis.
2. In the each "Item Name" sheet I will be doing some data analysis using general excel formulas and thus I cant afford to lose the analysis done on the prior day. 3.The macro should only append new data below the old and not delete all the data and refetch all data from master table as it will be time consuming, possibly result in deletion of my general formula working in each sheet and taxing the processor as well (it is fine to delete all data in the master table once that much data is captured by the respective "item name" sheets).

Your efforts are much appreciated. Thanking in anticipation

 

[mumps]

I'm not sure if I understood correctly, but try this macro:

Sub createSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, lastRow As Long, ws As Worksheet, item As Variant, srcWS As Worksheet, shName As String
    Set srcWS = Sheets("Master")
    Set RngList = CreateObject("Scripting.Dictionary")
    lastRow = srcWS.Range("B" & Rows.Count).End(xlUp).Row
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each item In RngList
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(item)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = item
            srcWS.Rows(1).Copy ActiveSheet.Cells(1, 1)
        End If
    Next item
    For Each item In RngList
        With Sheets(item)
            srcWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=item
            srcWS.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Columns.AutoFit
            srcWS.Range("B1").AutoFilter
        End With
    Next item
    Application.ScreenUpdating = True
End Sub

 

[mshah23]

I'm not sure if I understood correctly, but try this macro:

Sub createSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, lastRow As Long, ws As Worksheet, item As Variant, srcWS As Worksheet, shName As String
    Set srcWS = Sheets("Master")
    Set RngList = CreateObject("Scripting.Dictionary")
    lastRow = srcWS.Range("B" & Rows.Count).End(xlUp).Row
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each item In RngList
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(item)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = item
            srcWS.Rows(1).Copy ActiveSheet.Cells(1, 1)
        End If
    Next item
    For Each item In RngList
        With Sheets(item)
            srcWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=item
            srcWS.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Columns.AutoFit
            srcWS.Range("B1").AutoFilter
        End With
    Next item
    Application.ScreenUpdating = True
End Sub

https://drive.google.com/file/d/17xGdkoSIwkrCZo6Ip6Rvtq8Fq8TmYDgn/view?usp=sharing

Ive tried to explain my requirements in this file. Please go across the same

 

[mumps]

Try:

Sub createSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, lastRow As Long, ws As Worksheet, item As Variant, srcWS As Worksheet, shName As String
    Set srcWS = Sheets("Mastersheet")
    Set RngList = CreateObject("Scripting.Dictionary")
    lastRow = srcWS.Range("A" & Rows.Count).End(xlUp).Row
    For Each Rng In srcWS.Range("A2:A" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each item In RngList
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(item)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = item
            srcWS.Rows(1).Copy ActiveSheet.Cells(1, 1)
        End If
    Next item
    For Each item In RngList
        With Sheets(item)
            srcWS.Range("A1:A" & lastRow).AutoFilter Field:=1, Criteria1:=item
            srcWS.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Columns.AutoFit
            srcWS.Range("A1").AutoFilter
        End With
    Next item
    srcWS.UsedRange.Offset(1, 0).ClearContents
    Application.ScreenUpdating = True
End Sub

 

[mshah23]

Hi,
Thank you so much sir for your worthy efforts. Your above code fulfills all my requirements.
This will help me save on a lot of productive time.
Thank you once again

 

[mumps]

You are very welcome.