Macro to create new sheets with certain data

[CV12]

Hello everyone,

Using an AI bot, I managed to get a VBA script that searches for a filter word, and copies the matching data in that row to a new sheet. The script seems to work, except that the target sheet is overwritten each time. In the image below, only a sheet named section3 has been created, since it is the last is the sequence. So the data in the red boxes, section 1 and section 2 are overwritten by section3. Does anyone see the error in the VBA script so that sheets are created for section1, 2 and 3?

Thanks!

Sub FilterAndCopyRows()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim filterWords() As String
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long
    Dim copyRange As Range
    
    ' Set the source and target worksheets
    Set sourceSheet = ThisWorkbook.Sheets("BM1")
    
    ' Define filter words
    filterWords = Split("section1,section2,section3", ",")
    
    ' Filter and copy rows
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' Iterate over filter words
    For k = LBound(filterWords) To UBound(filterWords)
        ' Check if the target sheet already exists, otherwise create it
        On Error Resume Next
        Set targetSheet = ThisWorkbook.Sheets(filterWords(k))
        On Error GoTo 0
        If targetSheet Is Nothing Then
            Set targetSheet = ThisWorkbook.Sheets.Add(After:=sourceSheet)
            targetSheet.Name = filterWords(k)
        End If
        
        j = 1
        Set copyRange = Nothing
        
        For i = 1 To lastRow
            If sourceSheet.Range("A" & i).Value = filterWords(k) Then
                If copyRange Is Nothing Then
                    Set copyRange = sourceSheet.Rows(i)
                Else
                    Set copyRange = Union(copyRange, sourceSheet.Rows(i))
                End If
            End If
        Next i
        
        ' Copy the range of matching rows to the target sheet
        If Not copyRange Is Nothing Then
            copyRange.Copy Destination:=targetSheet.Rows(j)
            j = j + copyRange.Rows.Count
        End If
        
        ' Options for the target sheet
        targetSheet.Columns.AutoFit
    Next k
    
    ' Select the source sheet
    sourceSheet.Select
End Sub

 

[DanteAmor]

After this line:

' Check if the target sheet already exists, otherwise create it

Put this line:

Set targetSheet = Nothing

Full macro with ScreenUpdating instruction, just to make your macro faster.

Sub FilterAndCopyRows()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim filterWords() As String
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long
    Dim copyRange As Range
   
    Application.ScreenUpdating = False
   
    ' Set the source and target worksheets
    Set sourceSheet = ThisWorkbook.Sheets("BM1")
   
    ' Define filter words
    filterWords = Split("section1,section2,section3", ",")
   
    ' Filter and copy rows
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
   
    ' Iterate over filter words
    For k = LBound(filterWords) To UBound(filterWords)
        ' Check if the target sheet already exists, otherwise create it
        Set targetSheet = Nothing
        On Error Resume Next
        Set targetSheet = ThisWorkbook.Sheets(filterWords(k))
        On Error GoTo 0
        If targetSheet Is Nothing Then
            Set targetSheet = ThisWorkbook.Sheets.Add(After:=sourceSheet)
            targetSheet.Name = filterWords(k)
        End If
       
        j = 1
        Set copyRange = Nothing
       
        For i = 1 To lastRow
            If sourceSheet.Range("A" & i).Value = filterWords(k) Then
                If copyRange Is Nothing Then
                    Set copyRange = sourceSheet.Rows(i)
                Else
                    Set copyRange = Union(copyRange, sourceSheet.Rows(i))
                End If
            End If
        Next i
       
        ' Copy the range of matching rows to the target sheet
        If Not copyRange Is Nothing Then
            copyRange.Copy Destination:=targetSheet.Rows(j)
            j = j + copyRange.Rows.Count
        End If
       
        ' Options for the target sheet
        targetSheet.Columns.AutoFit
    Next k
   
    ' Select the source sheet
    sourceSheet.Select
    Application.ScreenUpdating = True
End Sub

 

[CV12]

Thank you!