Splitting a worksheet into separate worksheets based on a keyword in a cloumn

I need to split a worksheet based on a keyword in a column. There are 9000 rows and it takes around 3 hours to do this manually. I have code that splits the worksheets but I will have to do this 18 times and it will take too long. Here is my code for splitting worksheet. I need to implement this into a loop to loop 18 times for 18 different keywords but don't know how. Very new to VB and macros

Formula:

Sub SearchForString()



   Dim LSearchRow As Integer

   Dim LCopyToRow As Integer



   On Error GoTo Err_Execute

   

   'Start search in row 7

   LSearchRow = 7

   

   'Start copying data to row 7 in Sheet2 (row counter variable)

   LCopyToRow = 7

   

   While Len(Range("A" & CStr(LSearchRow)).Value)

   

      'If value in column E = "KEYWORD", copy entire row to Sheet2

      If Range("A" & CStr(LSearchRow)).Value = "KEYWORD" Then

      

         'Select row in Sheet1 to copy

         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select

         Selection.Copy

         

         'Paste row into Sheet2 in next row

         Sheets("Sheet2").Select

         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select

         ActiveSheet.Paste

         

         'Move counter to next row

         LCopyToRow = LCopyToRow + 1

         

         'Go back to Sheet1 to continue searching

         Sheets("Sheet1").Select

         

        '______________

   

   'Position on cell A3

   Application.CutCopyMode = False

   Range("A3").Select

   

   MsgBox "All matching data has been copied."

   

   Exit Sub

   

Err_Execute:

   MsgBox "An error occurred."

   

End Sub

Put a header in A1, eg AREA and try this code.

Option Explicit

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets("Sheet1") ' change All to the name of the worksheet the existing data is on
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column A has the criteria eg project ref
    wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
        
    Next I
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

It seemed to work fine with the sample workbook.

A new worksheet was created for each Area and the data for each Area was copied to the appropriate sheet.

What's different about the sheet you are trying it on?

The code I posted should work for any no of fields/columns as long as you put a heading in A1 which can easily be done with code.

If the headings aren't in row 1 then there would need some further, small, adjustments.

Here's the updated code.

Option Explicit

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Dim HeaderRow As Long

    Set wsAll = Worksheets("Sheet1") ' change All to the name of the worksheet the existing data is on
    
    ' change to whatever row the headers are in
    HeaderRow = 6
    
    wsAll.Range("A1").Value = "Field1"
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column A has the criteria eg project ref
    wsAll.Range("A" & HeaderRow & ":A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows(HeaderRow & ":" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
         wsNew.Range("A1").Value = ""
        wsCrit.Rows(2).Delete
        
    Next I
    
    wsAll.Range("A1").Value = ""
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub