splitting 1 sheet into 3 based on value in column AO

[jrwheeler]

I have a spreadsheet with a formula in column AO which returns 3 results "TRUE","FALSE" or "No KB" i need the entire rows for the whole of my "report" sheet to send the data to their individual sheets depending on what is in AO.

"TRUE" to sheet "Matches"
"FALSE" to sheet "No Matches"
"No KB" to sheet "No KB"

I'm using filter and copy/paste at the moment but its slow and clunky, is there a more effective way to do this? and if possible to avoid duplicating the data as the sheet can have 20,000+ rows per month

 

[Redwolfx]

What is the last column in your sheet?

 

[jrwheeler]

What is the last column in your sheet?

AO is the last one

 

[Redwolfx]

Try:

This code is untested

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets("Report").Range("AO100000").End(xlUp).Row
    For Each mycell In Range("AO2:AO" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets("Report").Range("AO2:AO" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            If WS.Name = "True" Then
                Set WS = Worksheets("Matches")
            ElseIf WS.Name = "False" Then
                Set WS = Worksheets("No Matches")
            End If
            
            Sheets("Report").Range("A1:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
        End If
        Sheets("Report").Rows("1:" & LastRow).Hidden = False
    Next WS
    
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name = "True" Or WS.Name = "False" Then
            WS.Delete
        End If
    Next WS
    
Application.ScreenUpdating = True
End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

 

[jrwheeler]

Try:

This code is untested

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets("Report").Range("AO100000").End(xlUp).Row
    For Each mycell In Range("AO2:AO" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets("Report").Range("AO2:AO" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            If WS.Name = "True" Then
                Set WS = Worksheets("Matches")
            ElseIf WS.Name = "False" Then
                Set WS = Worksheets("No Matches")
            End If
            
            Sheets("Report").Range("A1:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
        End If
        Sheets("Report").Rows("1:" & LastRow).Hidden = False
    Next WS
    
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name = "True" Or WS.Name = "False" Then
            WS.Delete
        End If
    Next WS
    
Application.ScreenUpdating = True
End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

this works great but it takes a long time to complete excel/vba will just stay in running macro state for ages is there a way around this or is my machine just not powerful enough?

 

[Redwolfx]

Try adding

Application.Calculation = xlCalculationManual

at the beginning, and

Application.Calculation = xlCalculationAutomatic

At the end

Like this:

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

LastRow = Sheets("Report").Range("AO100000").End(xlUp).Row
    For Each mycell In Range("AO2:AO" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets("Report").Range("AO2:AO" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            If WS.Name = "True" Then
                Set WS = Worksheets("Matches")
            ElseIf WS.Name = "False" Then
                Set WS = Worksheets("No Matches")
            End If
            
            Sheets("Report").Range("A1:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
        End If
        Sheets("Report").Rows("1:" & LastRow).Hidden = False
    Next WS
    
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name = "True" Or WS.Name = "False" Then
            WS.Delete
        End If
    Next WS
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub