Separating Sheet into different sheets based on cell "Containing" string in another sheet...

[rjbur]

Here is my challenge and I am continuing to search the forum for an example, so if there is another useful thread, please point me in that direction.

I have a spreadsheet/workbook that contains two (2) sheets. Lets call them "CRITERIA" and "DATA". I need to perpetrate the DATA into NEW sheets based on the CRITERIA and if the sheet does not exist, create it based on the Header Row in the CRITERIA sheet. If it does exist, then simply add the data to the end of the existing content in the sheet.

DATA contains a long list of... you guessed it, data. Column-A contains "text" or a string. For my example, anything past Column A is along for the ride.

Here is what the CRITERIA sheet might look like:

	A	B
1	CARS	COLOR
2	Dodge	Red
3	Chevy	Green
4	GMC	Blue

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

Now the DATA sheet contains say something like:

A B C 1 Theredrugwill… Row 1 data More Row 1 data 2 Chevycarsare… Row 2 data More Row 2 data 3 Theskyisblue… Row 3 data More Row 3 data 4 GMCTruckare… Row 4 data More Row 4 data 5 DodgePowerWagon… Row 5 data More Row 5 data 6 Thegrassisgreeneron… Row 6 data More Row 6 data <colgroup><col><col><col><col></colgroup><tbody> </tbody>

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

Note that I have purposely removed the spacing as the Column-A needs to "contain" the letters and not match a word. As long as somewhere in the cell it has the combination of characters, it contains it and the complete ROW needs to be MOVED to another sheet. If nothing matches, then it is not processed and stays in the current sheet.

In the CRITERIA sheet you can see there are now two columns with the headers of CARS and COLOR. When macro finishes I should have two new sheets, one CARS and the other COLOR.

The other twist is that should I add a third column to CRITERIA it should be processed as well. So we have two open dimensions, the size of the elements under each header and the number of headers to be processed against the DATA.

I did not add a no-match row so that it would stay in the DATA sheet...

I have to run, so I will read through this later today to make sure it makes sense.

Thanks for your time,

Rich

 

[rjbur]

Mumps you are truly gifted, IT WORKS!!!

So the final code looks like this after I replaced the lines you recommended as well as deleted the no longer needed "LastRow" variable declaration and setting at the top of the code.


ONE MORE CHALLENGE - I would like to MOVE the rows over to their new sheets, thus leaving in the "Data" sheet only the rows that were not processed since they meet non of the "Criteria"

I'm searching for this now, but betting you'll beat me to the solution..

Sub AddSheet()    Application.ScreenUpdating = False
    Dim lColumn As Long
    lColumn = Sheets("Criteria").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim category As Range
    Dim val As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim ws As Worksheet
    For Each category In Sheets("Criteria").Range(Cells(1, 1), Cells(1, lColumn))
        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("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    'sAddr = ""
                End If
            Next val
        Else
            Sheets("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    sAddr = ""
                End If
            Next val
        End If
    Next category
    Application.ScreenUpdating = True
 End Sub

 

[mumps]

Removing the rows will create a problem. Let's assume that the line "GMCTruckare…green" in the Data sheet is moved to the "CARS" sheet because it contains "GMC". Now it is no longer in the Data sheet. This means that it is not available for the macro to place it in the COLOR sheet because it contains the color "green" so your COLOR sheet will be missing that data.

 

[rjbur]

Ahhh good point...

Hmm... Trying to figure out how to tell which rows in "Data" did not meet any of the "Criteria".

Figured that if we "moved" the rows, what was left would be the unprocessed.

There are ways I can think of possibly "tagging" rows that have been processed. Off the top of my head we "highlight" the complete row or just the cell in Column-A of "Data" in say... yellow... color doesn't really matter... If it was processed / matched any of the criteria, then the row is highlighted. If it is double processed, who cares, we highlight a yellow row or cell with yellow again. Then at the end, when we look at "Data" and see a row or cell that is not highlighted we know it has not been processed.

This helps quickly evaluate that all data has been processed and allow for a quick review and study as to why something was not. Usually this would end up with and adjustment of the "Criteria" and a reprocessing, after, of course, restoring a backup of the "Data" we were smart enough to make...

What do you think, a possible solution?

 

[rjbur]

OK here is what I ended up with:

I added

foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)

To both of the the Do Loops:

Do
   foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
   foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)
   Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
Loop While foundVal.Address <> sAddr

So the final code looks like:

Sub AddSheet()    Application.ScreenUpdating = False
    Dim lColumn As Long
    lColumn = Sheets("Criteria").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim category As Range
    Dim val As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim ws As Worksheet
    For Each category In Sheets("Criteria").Range(Cells(1, 1), Cells(1, lColumn))
        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("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    'sAddr = ""
                End If
            Next val
        Else
            Sheets("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    sAddr = ""
                End If
            Next val
        End If
    Next category
    Application.ScreenUpdating = True
 End Sub

And it now highlights processed rows in YELLOW and I can tell which ones it has not processed.

Thanks for all your help!!

I now need to study what you have provided and learn from this experience to expand my understanding.....

 

[mumps]

It was my pleasure. I'm glad everything worked out.

 

[rjbur]

Today is a study day... I was able to incorporate the code, but now I have a slight (always a fun word as it may not equate to the amount of code) adjustment.

In the new "sheets" that the "Data" has been copied to, I do not want the contents of Column-A from the original "Data" sheet.

In other words, it is no longer a copy complete "row" but rather Column-B on is what I really need in the new sheets.

So as I'm thinking about this, one easy (another fun word) might be that after a "Criteria" column has completed its evaluation and creation of the new sheet, we simply delete Column-A in the new sheet. That should preserver much of the existing code, right?

I'm off to lunch. When I get back I'll have to work more on this.

Mumps - I wish I could buy you lunch.... This has been great.... New to this forum and learning much...

 

[mumps]

Try:

Sub AddSheet()
    Application.ScreenUpdating = False
    Dim lColumn1 As Long
    lColumn1 = Sheets("Criteria").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim lColumn12 As Long
    Dim category As Range
    Dim val As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim ws As Worksheet
    For Each category In Sheets("Criteria").Range(Cells(1, 1), Cells(1, lColumn1))
        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("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        lColumn2 = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
                        Sheets("Data").Range(Sheets("Data").Cells(foundVal.Row, 2), Sheets("Data").Cells(foundVal.Row, lColumn2)).Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    'sAddr = ""
                End If
            Next val
        Else
            Sheets("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        lColumn2 = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
                        Sheets("Data").Range(Sheets("Data").Cells(foundVal.Row, 2), Sheets("Data").Cells(foundVal.Row, lColumn2)).Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        foundVal.EntireRow.Interior.Color = RGB(255, 255, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    sAddr = ""
                End If
            Next val
        End If
    Next category
    Application.ScreenUpdating = True
 End Sub

 

[rjbur]

Alright, there is definitely WOW and Awesomeness here as IT WORKS!

Just about have my task completed, but definitely have some studying and learning to do.

Thanks once again for all the help and time.

Rich

PS: It seems the first row in the resulting new sheets is blank? Hmmm

 

[mumps]

Could I suggest that you insert a blank row 1 in the Data sheet and then type in the headers for each column of data. Then we could get the macro to copy those headers into the new sheets.

 

[rjbur]

Could I suggest that you insert a blank row 1 in the Data sheet and then type in the headers for each column of data. Then we could get the macro to copy those headers into the new sheets.

Well in the new sheets I do not want the headers, just the data, otherwise I would say sure...