First Post: Macro / VBA to Move Entire Rows to New Sheets Based on Multiple Criteria From a List In A Separate Column

[jholly1984]

Hi everyone,

First I just want to say thank you to everyone who has been part of this site and community over the years. I have learned a ton and it is very much appreciated.

For this post, I am currently working on a problem that I have been unable to fully solve. There have been others posts on here and on Youtube that look at moving rows to another sheet based on criteria... but I have not seen one that looks at moving cells to different sheets based on dynamic criteria in a list. Hoping someone might be able to help.

Here is a quick view of what my sheet looks like:

Goal: I would like to be able to copy all rows to a new sheet where the keyword in column a CONTAINS the filter word in column H. Each filter in H would need to have its own sheet.

So... go through column A, identify all keywords that contain "laptop" and copy them to a new sheet called "Laptop". Then do the same each of the filter words in column H and create new sheets for each.

I have seen some options that move based on a specific cell value or a date.. but I have not been able to find anything that a) checks based on a full list of values in a column or b) extracts data based on if the cell 'contains' the filter).

I am hopnig the macros can identify and group the keyword sets automatically vs having to manually filter and assign a category in a separate column.

Hope that makes sense. Thank you for your time. Very much appreciated.

 

[jolivanes]

You could try this

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H5")
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
End Sub

 

[jolivanes]

If you spruce it up a little bit, you'll get something like this:

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H" & sh1.Cells(Rows.Count, 8).End(xlUp).Row)
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub

 

[jholly1984]

Thank you sooooo much! Your code is working BEAUTIFULLY!

Thinking longer term I decided to move the filters off of the data tab to their own tab - as that list grows I think it'll be more manageable that way (I changed your initial code - I haven't tried the new one you just posted yet - but I will!

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Set sh1 = Worksheets("Data") '<-----Sheet with all the data. Change as required
Set sh2 = Worksheets("Filters")
For Each c In sh2.Range("A2:A5")
If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
Next i
Next c
End Sub


One quick (hopefully follow-up question: How would I have it carry over the column headers onto the new sheets?

Thank you again for the help!

 

[jholly1984]

If you spruce it up a little bit, you'll get something like this:

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H" & sh1.Cells(Rows.Count, 8).End(xlUp).Row)
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub

Thanks for this as well... I'm fairly new to VBA and learning... What does the sprucing up change in the way that the function works (or the results)?

 

[jolivanes]

They're both the same. No change in the final result.
The 2nd one returns to the original sheet at the end and has "ScreenUpdating" False and True added to avoid screen flickering.

This should also give you the headers.

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H5")
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then
                With Sheets(c.Value)
                    .Cells(1, 1).Resize(, 6).Value = sh1.Cells(1, 1).Resize(, 7).Value
                    .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
                End With
            End If
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub

 

[jholly1984]

Thank you so much for helping with this and helping so quickly. This is truly a game changing macro for the kind of work we do. You are the best!

 

[jolivanes]

Thank you for the kind words and for letting us know that all is as wanted.
Good Luck

 

[jolivanes]

I neglected to update a couple lines.
Change this

For Each c In sh1.Range("H2:H5")

to this

For Each c In sh1.Range("H2:H" & Cells(Rows.Count, 8).End(xlUp).Row)

to be more dynamic in that Column
and this

Sheets("Sheet1").Select

to this

sh1.Select

Since we set sh1 to that Sheet1.
Sorry about that.

 

[jholly1984]

No problem at all. Thank you again for the continued support.

One new item that popped up while we have been testing this and realizing its power....is the ability to also count up the actual instances of each modifier as a summary tab.

So if the list is:

Headphones
Laptops
Etc

It would be great to be able to run a separate first pass macros that analyzes the data and counts the instances of each. Is that easy to do?

Output would be something like this: I am using an online text analyzer tool to do this for me now (which produced what you see below)... but maybe excel is better to handle it.