Add or Update Worksheets based on Column Status from Master Data to Another Sheet

There are two ways you could do this. The first way would be to run a macro manually by clicking a button on the APPLICATIONS sheet each time you want to update the data. Another way would be to automatically update the data one row at a time as each row of data is added to the APPLICATIONS sheet and the status is inserted into column X. The advantage to this approach is that you would not have to run any macro manually. The update would be automatic. Which approach would work best for you? Also, attach another version of the file which has data in the other columns. This would make testing a possible solution easier.

Try the attached file. The macro is triggered after you enter the status in column X and press the RETURN key. It is important that the status in column X be the last column to be populated. Therefore, enter all the data for columns A to W, then the data in columns Y to AA and lastly the status in column X.

Try the attached file.

Hi mumps1 (Forum Expert)
It almost doing the same thing which was my requirement.
Only problem is whenever i selected any row or multiple row from the master data (Application sheet) for deletion or copy paste the data in the master data (Application sheet) . It is showing run time error.
And when the status of data is going to another sheet , only 1st row is coming into the excel table format and rest of data coming into next to table Line.
I am attaching with very few entries , so that you can test it

Hope you will help me in this , as you have done the impossible thing for me.
Thank you so much and I am just waiting for your response.
And Yes , as tagged you are an EXPERT.

Try the attached version. The error when deleting or copying rows should now be fixed. The macro works in the following manner:
In the APPLICATION sheet:
- If you add any new status, the new sheet will be created and the row of data will be copied to it.
- If you change any existing status to a name that does not have an existing corresponding sheet, the new sheet will be created and the row of data will be moved to the new sheet.
- If you change any existing status to a name that has an existing corresponding sheet, the row of data will be moved to the existing corresponding sheet.

Try this version of the code to fix the error.

Dim oldSH As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("X:X")) Is Nothing Then Exit Sub
    If Target.Column = 24 Then
        oldSH = Target.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("X:X")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim SNo As Range
    If oldSH = "" And Target.Column <> 1 Then
        Dim lastRow As Long
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        Else
            With Sheets(Target.Value)
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        End If
        Sheets("APPLICATIONS").Activate
    ElseIf oldSH <> "" And Target.Column = 24 Then
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not SNo Is Nothing Then
                    With Sheets(oldSH)
                        SNo.EntireRow.Copy Sheets(Target.Value).Cells(lastRow, 1)
                        SNo.EntireRow.Delete
                    End With
                End If
            End With
        Else
            Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                With Sheets(Target.Value)
                    lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    SNo.EntireRow.Copy .Cells(lastRow, 1)
                    SNo.EntireRow.Delete
                End With
            End If
        End If
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

I still don't understand what you mean by:

Also data are going to another sheet (1st entry in the Table column correctly and after that 2nd entry out of table. Like if we do the "Joined" status 2 times then its 1st entry in Joined sheet is in the table , but 2nd entry is out of the table.

I tested the macros by adding a new status, changing an existing status to a status that has an existing sheet and changing an existing status to a status with no existing sheet and the macros worked properly. Please explain in detail, step-by-step, what you are doing referring to specific cells, rows, columns and sheets using a few examples from your data. Also, attach an updated file that shows how the macros are not working for you.

Try the attached file.

Replace the previous Worksheet_SelectionChange macro with this one. That should fix the run time error.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 24 And Target.Count = 1 Then
        oldSH = Target.Value
    End If
End Sub

Which columns in APPLICATIONS are subject to change?

Try:

Dim oldSH As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 24 And Target.CountLarge = 1 Then
        oldSH = Target.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:AA")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim SNo As Range, newrow As ListRow, tbl As ListObject
    If oldSH = "" And Target.Column = 24 Then
        Dim lastRow As Long
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        Else
            With Sheets(Target.Value)
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        End If
        Sheets("APPLICATIONS").Activate
    ElseIf oldSH <> "" And Target.Column = 24 Then
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not SNo Is Nothing Then
                    With Sheets(oldSH)
                        SNo.EntireRow.Copy Sheets(Target.Value).Cells(lastRow, 1)
                        SNo.EntireRow.Delete
                    End With
                End If
            End With
        Else
            Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                With Sheets(Target.Value)
                    Set tbl = .ListObjects(Target.Value)
                    Set newrow = tbl.ListRows.Add
                    lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    SNo.EntireRow.Copy .Cells(lastRow, 1)
                    SNo.EntireRow.Delete
                End With
            End If
        End If
    End If
    If Target.Column <> 24 Then
        With Sheets(Range("X" & Target.Row).Value)
            Set SNo = .Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                .Cells(SNo.Row, Target.Column) = Target.Value
            End If
        End With
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Please note that you cannot change column A in APPLICATIONS because the macros uses that value as a unique identifier for each row in the sheet. If you must change any value in column A in APPLICATIONS, you can do so, but you will have to manually change the corresponding value in the other sheet for the corresponding row.

It's working for me. Try the attached file.

Look in column X in the row that you are changing. Does the sheet named according to column X exist?

I just realized what the problem is. Replace this code:

If Target.Column <> 24 Then
        With Sheets(Range("X" & Target.Row).Value)
            Set SNo = .Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                .Cells(SNo.Row, Target.Column) = Target.Value
            End If
        End With
    End If

with this:

If Target.Column <> 24 Then
        If Range("X" & Target.Row) <> "" Then
            With Sheets(Range("X" & Target.Row).Value)
                Set SNo = .Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not SNo Is Nothing Then
                    .Cells(SNo.Row, Target.Column) = Target.Value
                End If
            End With
        End If
    End If

Hi Mumps1,
You are very close to it .
Now the addition and changes are doing ,

The changes are going to correct sheet, however the status name is not changing.
I have made last entry, as joined status.
It is correctly created one sheet as "Joined", when i have changed the status to Interview Select, it moves to interview select,
however the final status in Interview Select sheet is showing as Joined.
If you see in Interview Select sheet the Final status is showing as joined. It moves to the correct sheet only the status should be "Interview Select"

Now I Think it is just a moment and you crack it , It will give me very helpful
Attaching the sheet for your reference.

thanks and Regards,
Sanjay Kumar

Try:

Dim oldSH As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 24 And Target.CountLarge = 1 Then
        oldSH = Target.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:AA")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim SNo As Range, newrow As ListRow, tbl As ListObject
    If oldSH = "" And Target.Column = 24 Then
        Dim lastRow As Long
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        Else
            With Sheets(Target.Value)
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        End If
        Sheets("APPLICATIONS").Activate
    ElseIf oldSH <> "" And Target.Column = 24 Then
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not SNo Is Nothing Then
                    With Sheets(oldSH)
                        SNo.EntireRow.Copy Sheets(Target.Value).Cells(lastRow, 1)
                        SNo.EntireRow.Delete
                    End With
                End If
            End With
        Else
            Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                With Sheets(Target.Value)
                    Set tbl = .ListObjects(Target.Value)
                    Set newrow = tbl.ListRows.Add
                    lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    SNo.EntireRow.Copy .Cells(lastRow, 1)
                    .Cells(lastRow, 24) = Target
                    SNo.EntireRow.Delete
                End With
            End If
        End If
    End If
    If Target.Column <> 24 And Range("X" & Target.Row) <> "" Then
        With Sheets(Range("X" & Target.Row).Value)
            Set SNo = .Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                .Cells(SNo.Row, Target.Column) = Target.Value
            End If
        End With
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Let's give it another try:

Dim oldSH As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 24 And Target.CountLarge = 1 Then
        oldSH = Target.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:AA")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim SNo As Range, newrow As ListRow, tbl As ListObject
    If oldSH = "" And Target.Column = 24 Then
        Dim lastRow As Long
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        Else
            With Sheets(Target.Value)
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Target.EntireRow.Copy .Cells(lastRow, 1)
            End With
        End If
        Sheets("APPLICATIONS").Activate
    ElseIf oldSH <> "" And Target.Column = 24 Then
        If Not Evaluate("isref('" & Target.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Target.Value
            With Sheets(Target.Value)
                Rows(3).Copy .Cells(1, 1)
                .ListObjects.Add(xlSrcRange, .Range("$A$1:$AA$1"), , xlYes).Name = Target.Value
                .Range("A1").AutoFilter
                Set tbl = .ListObjects(Target.Value)
                Set newrow = tbl.ListRows.Add
                lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not SNo Is Nothing Then
                    With Sheets(oldSH)
                        SNo.EntireRow.Copy Sheets(Target.Value).Cells(lastRow, 1)
                        Sheets(Target.Value).Cells(lastRow, 24) = Target
                        SNo.EntireRow.Delete
                    End With
                End If
            End With
        Else
            Set SNo = Sheets(oldSH).Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                With Sheets(Target.Value)
                    Set tbl = .ListObjects(Target.Value)
                    Set newrow = tbl.ListRows.Add
                    lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    SNo.EntireRow.Copy .Cells(lastRow, 1)
                    .Cells(lastRow, 24) = Target
                    SNo.EntireRow.Delete
                End With
            End If
        End If
    End If
    If Target.Column <> 24 And Range("X" & Target.Row) <> "" Then
        With Sheets(Range("X" & Target.Row).Value)
            Set SNo = .Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not SNo Is Nothing Then
                .Cells(SNo.Row, Target.Column) = Target.Value
            End If
        End With
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

My pleasure.

The method I suggested is the easiest and most convenient way to achieve what you want. You could make it more fool proof by putting a data validation drop down list in column X where the user could simply click on any cell in column X and select from the drop down list. This would avoid any typographical errors. Using the button method, you would have to decide which status to use as a filter and then have a message box pop up where you would manually enter the desired status. The drop down list method would avoid manual entry altogether. All it would take is one click without having to manually enter data.

Place this macro in a separate module. The macro assumes that after you migrate the previous master data, the workbook will contain only the APPLICATIONS sheet. Run the macro once to create all the new sheets based on column X. Then if you manually add additional rows to that data, the previous method will automatically copy the row to the appropriate sheet.

Sub MigrateData()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim Val As String, srcWS As Worksheet, rngList As Object
    Set srcWS = Sheets("APPLICATIONS")
    Dim i As Long, v1 As Variant
    v1 = srcWS.Range("X4", Range("X" & Rows.Count).End(xlUp)).Value
    Set rngList = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(v1, 1)
        Val = v1(i, 1)
        If Not rngList.Exists(Val) And Val <> "" Then
            rngList.Add Val, Nothing
            With srcWS
                .Cells(3, 1).CurrentRegion.AutoFilter 24, Val
                If Not Evaluate("ISREF('" & Val & "'!A1)") Then
                    ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Val
                    .Range("A3", .Range("AA" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy Cells(1, 1)
                    .Range("A3").AutoFilter
                End If
            End With
        End If
    Next i
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Hi,
When I try to copy and paste (migrate the Data) from different sheet
Below error showing for our 1st macro:
Run time error 9.
Paste till "W" Column will not give any error, If we paste till "X" Column then error is showing.



After debug and press to reset and then i click the macro for New Module Macro is running.
Also When after Macro is running the Status sheets are not coming in Table form .
It is splitting into Simple Sheet.
I am attaching the Application, Error and some data to migrate for your reference.

Thanks and Regards,
Sanjay Kumar