Search though 10,000 lines to split across various tabs

[glynn1969]

Hello i have a work sheet with 10s of thousands of row entries and i am looking to search for a specific value in column A and based on that value copy the whole row to a specific worksheet.

I have simplified my example - here i have a worksheet with three variables in column A "Treadmill", "Bike" and "Rower" and based on the entry in column A i want to move the whole row to a tab called "Treadmill", "Bike" or "Rower". This does work but when i extend my data to thousands of rows excels hangs and takes a very long time to run.


Are there any quicker methods (note the number of splitting option requirements will rise to around 40/50 tabs)

Sub split_Excercise()
Dim totalentries As Integer
Dim treadmillentries As Integer
Dim bikeentries As Integer
Dim rowerentries As Integer
Dim i As Integer


Sheets(Array("Treadmill", "Bike", "Rower")).Select
Range("A2:e1048576").Select
Selection.ClearContents
Sheets("All Excercise").Select


totalentries = Worksheets("All Excercise").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To totalentries
If Worksheets("All Excercise").Cells(i, 1).Value = "Treadmill" Then
Worksheets("All Excercise").Rows(i).Copy
Worksheets("Treadmill").Activate
treadmillentries = Worksheets("Treadmill").Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("Treadmill").Cells(treadmillentries + 1, 1).Select
ActiveSheet.Paste
Cells(1, 1).Select

ElseIf Worksheets("All Excercise").Cells(i, 1).Value = "Bike" Then
Worksheets("All Excercise").Rows(i).Copy
Worksheets("bike").Activate
bikeentries = Worksheets("bike").Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("bike").Cells(bikeentries + 1, 1).Select
ActiveSheet.Paste
Cells(1, 1).Select

ElseIf Worksheets("All Excercise").Cells(i, 1).Value = "Rower" Then
Worksheets("All Excercise").Rows(i).Copy
Worksheets("Rower").Activate
rowerentries = Worksheets("rower").Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("rower").Cells(rowerentries + 1, 1).Select
ActiveSheet.Paste
Cells(1, 1).Select
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("All Excercise").Activate
Cells(1, 1).Select

End Sub

 

[sheetspread]

First post in the link below pastes as values, second post keeps the formulas:

Keeping the formulas when you split a worksheet into multiple worksheets by change in row value

This is one of many similar macros that uses the advanced filter to give each category its own named tab: Option Explicit Sub ParseItems() 'Author: Jerry Beaucaire 'Date: 11/11/2009 'Summary: Based on selected column, data is filtered to individual sheets ' Creates sheets...

www.mrexcel.com

 

[dmt32]

Hi,
try following & see if does what you want

Option Explicit
Sub Split_Excercise()
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant
    
    On Error GoTo progend
    
'******************************************************************************************************

'your master sheet
    Set wsData = ThisWorkbook.Worksheets("All Excercise")
    
'Column you are filtering
    FilterCol = "A"
    
'******************************************************************************************************
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
    
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
        
        Set Datarng = .Range("A1").CurrentRegion
        
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
        
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
            If FilterRange.Value <> "" Then
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'check if sheet exists
                If Not Evaluate("ISREF('" & FilterRange.Value & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = FilterRange.Value
                End If
'set object variable to sheet
                Set wsNames = Worksheets(FilterRange.Value)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If
'autofit columns
            wsNames.UsedRange.Columns.AutoFit
'clear from memory
            Set wsNames = Nothing
        Next
        .Select
    End With
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then
        MsgBox (Error(Err)), vbCritical, "Error"
        Err.Clear
    End If
End Sub

Code should copy each row for value in column A to sheet of same name - if that sheet does not exist, code should create it

Dave

 

[glynn1969]

That is absolutely fantastic and does more than i asked for..many thanks. Will need to spend hours now trying to decifer how it all works.

 

[glynn1969]

not sure how to give you a credit score Dave..but manythanks again

 

[dmt32]

not sure how to give you a credit score Dave..but manythanks again

A thank-you to all who contributed to your thread is all that is needed & always appreciated.

Dave

 

[jkpieterse]

Just a question: Why split the data across multiple tabs? As it is now you can report more easily.

 

[glynn1969]

Hi
The main use for this will be for accounting and will be for Cost Centres to be issued to individual areas (with master data consisiting of around 75,000 rows) - my example here was just as an example for a sheet i was working on for my sons gym record.