VLOOKUP type question to copy part of a row once the value is hound in a range

[Phantasm]

So I have values such as "SAW", "BP", "MILL", "LATHE" in the range of G2:O250 in WORKSHEET1.

What I want to do is create a new worksheet tab called "SAW" & have it import the any row from A:O on WORKSHEET1 that has that has the cell value of "SAW"in it. This will basically show me all jobs olny that have a SAW operation. I will do the same on other tabs for the other values.

Any help is appreaciated.

 

[Phantasm]

so i have values such as "saw", "bp", "mill", "lathe" in the range of g2250 in worksheet1.

What i want to do is create a new worksheet tab called "saw" & have it import the any row from a on worksheet1 that has that has the cell value of "saw"in it. This will basically show me all jobs olny that have a saw operation. I will do the same on other tabs for the other values.

Any help is appreaciated.

bump

 

[Yongle]

Does each cell in range G2:O250 contain either a single value or else is blank?
Is it always 250 rows or do you simply want all rows?
Can each operation appear in any column (G:O) or does "SAW" always appear in same column etc?

 

[Fluff]

Further to Yongle's questions, can saw appear multiple times in the same row?

 

[Phantasm]

Further to Yongle's questions, can saw appear multiple times in the same row?

Does each cell in range G2:O250 contain either a single value or else is blank? - Yes, there are about 15 different operations that I use and all are single operations (no SAW/WELD). Also, there are empty cells.

Is it always 250 rows or do you simply want all rows? - I dont see it going more than 250, but using all rows would do no harm.

Can each operation appear in any column (G:O) or does "SAW" always appear in same column etc? - Each operation can appear in any of the columns & they may appear multiple times in the same row.

Thanks for the help guys!

 

[Yongle]

Try this and let me know

- place code below in the SHEET module
(right click on sheet tab \ view code \ paste in window on right)
- and then run CreateSheets

Place at the top -before all other procedures (makes variables available to all procedures in same module)

Option Explicit
Private Ops As Collection, Op As Variant
Private DataRange As Range, OpsRange As Range, Cel As Range, MatchRange As Range
Private LastRow As Long, r As Long
Private SheetName As String
Private ws As Worksheet

Main procedure calls other subs

Sub CreateSheets()
    Optimise True
    SetRanges
    CreateUniqueList
    AddSheets
    CopyRows
    Optimise False
End Sub

Other subs

Private Sub Optimise(OnOff As Boolean)
    With Application
        Select Case OnOff
            Case True:      .ScreenUpdating = False:    .Calculation = xlCalculationManual
            Case False:     .ScreenUpdating = True:     .Calculation = xlCalculationAutomatic
        End Select
    End With
End Sub

Private Sub SetRanges()
    Set DataRange = Me.Cells(1).CurrentRegion
    With DataRange
        Set OpsRange = .Offset(1, 6).Resize(.Rows.Count - 1, .Columns.Count - 6)
        LastRow = .Rows.Count
    End With
End Sub

Private Sub CreateUniqueList()
    Set Ops = New Collection
    On Error Resume Next        'required to get unique list this way
    For Each Cel In OpsRange
        If Cel <> vbNullString Then Ops.Add Cel, Cel
    Next Cel
End Sub

Private Sub AddSheets()         'deletes old one first if it exists with same name
    Application.DisplayAlerts = False
    On Error Resume Next        'sheet name may be invalid or sheet may not exist
    For Each Op In Ops
        SheetName = Op
        Sheets(SheetName).Delete
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = SheetName
        Me.Rows(1).Copy ws.Cells(1)
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub CopyRows()
    On Error Resume Next
    For Each Op In Ops
        SheetName = Op
        Set ws = Sheets(SheetName)
        For r = 2 To LastRow
            Set MatchRange = OpsRange.Resize(1).Offset(r - 2)
            If WorksheetFunction.CountIf(MatchRange, SheetName) > 0 Then
                Me.Rows(r).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End If
        Next r
    Next Op
End Sub

I avoided filtering - with only 250 rows copying one row at a time should be very quick

 

[Phantasm]

Try this and let me know

- place code below in the SHEET module
(right click on sheet tab \ view code \ paste in window on right)
- and then run CreateSheets

Place at the top -before all other procedures (makes variables available to all procedures in same module)

Option Explicit
Private Ops As Collection, Op As Variant
Private DataRange As Range, OpsRange As Range, Cel As Range, MatchRange As Range
Private LastRow As Long, r As Long
Private SheetName As String
Private ws As Worksheet

Main procedure calls other subs

Sub CreateSheets()
    Optimise True
    SetRanges
    CreateUniqueList
    AddSheets
    CopyRows
    Optimise False
End Sub

Other subs

Private Sub Optimise(OnOff As Boolean)
    With Application
        Select Case OnOff
            Case True:      .ScreenUpdating = False:    .Calculation = xlCalculationManual
            Case False:     .ScreenUpdating = True:     .Calculation = xlCalculationAutomatic
        End Select
    End With
End Sub

Private Sub SetRanges()
    Set DataRange = Me.Cells(1).CurrentRegion
    With DataRange
        Set OpsRange = .Offset(1, 6).Resize(.Rows.Count - 1, .Columns.Count - 6)
        LastRow = .Rows.Count
    End With
End Sub

Private Sub CreateUniqueList()
    Set Ops = New Collection
    On Error Resume Next        'required to get unique list this way
    For Each Cel In OpsRange
        If Cel <> vbNullString Then Ops.Add Cel, Cel
    Next Cel
End Sub

Private Sub AddSheets()         'deletes old one first if it exists with same name
    Application.DisplayAlerts = False
    On Error Resume Next        'sheet name may be invalid or sheet may not exist
    For Each Op In Ops
        SheetName = Op
        Sheets(SheetName).Delete
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = SheetName
        Me.Rows(1).Copy ws.Cells(1)
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub CopyRows()
    On Error Resume Next
    For Each Op In Ops
        SheetName = Op
        Set ws = Sheets(SheetName)
        For r = 2 To LastRow
            Set MatchRange = OpsRange.Resize(1).Offset(r - 2)
            If WorksheetFunction.CountIf(MatchRange, SheetName) > 0 Then
                Me.Rows(r).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End If
        Next r
    Next Op
End Sub

I avoided filtering - with only 250 rows copying one row at a time should be very quick

Thank you for this. I will get back to you tomorow on if it works, right now Im trying to slay bigger dragons...lol.

 

[Yongle]

If you have any follow up question, please post them on the thread.
Here are the answers to your PM questions

Basicly, it seems like its grabbing too many columns because its looking past column "O"

.
Try replacing

Set OpsRange = .Offset(1, 6).Resize(.Rows.Count - 1, .Columns.Count - 6)

With

Set OpsRange = .Offset(1, 6).Resize(.Rows.Count - 1, 9)

Also, is there any way that I can get it to keep my formatting of the worksheet it grabs from (column sizes ect..)

Try adding

Me.Rows(1).Copy
ws.Cells(1).PasteSpecial (xlPasteColumnWidths)
[B]

After this line[/B]

Me.Rows(1).Copy ws.Cells(1)

And can I have the first row sortable like on the initial worksheet...

What does this mean?

 

[Phantasm]

https://imgur.com/a/xOdMQmP

Here is a screenshot of the main sheet. The top row is the sortable header. Thanks again.

 

[Yongle]

And can I have the first row sortable like on the initial worksheet...

To add Data Filter to each new sheet

add this line

ws.Cells(1, 1).AutoFilter

after this line

Me.Rows(r).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)