Pared down Data

hi there, I've downloaded file without any troubles. I've reposted same file in xls and xlsm format.

The workbook contains three sheets: Test1, Test2, Test3 (you need to change them in the code for different sheet names). The data starts from A1 on all sheets and down. Three new sheets: Test1B, Test2B, Test3B created with 25th data from each sheet Column A.

Code inside:

Option Explicit
Sub test()

Dim main As Workbook, sh_arr, nm, data, colcount As Long, rowscount As Long, result, i As Long, _
n As Long, j As Long, err_str As String

Application.ScreenUpdating = 0

Set main = ActiveWorkbook
sh_arr = Split("Test1,Test2,Test3", ",")

On Error Resume Next

For Each nm In sh_arr

    If Err.Number = 0 Then
        
        data = main.Sheets(nm).Range("a1").CurrentRegion
        
        colcount = UBound(data, 2)
        rowscount = UBound(data)
        
        ReDim result(1 To rowscount, 1 To colcount)

        For i = 25 To rowscount Step 25
            j = j + 1
            For n = 1 To colcount
                result(j, n) = data(i, n)
            Next
        Next

        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Range("a1").Resize(j, colcount) = result
            .Name = nm & "B"
        End With
        
        ReDim result(1 To rowscount, 1 To colcount)
        j = 0
        
    Else
    
        err_str = err_str & nm & Chr(10)
        Err.Clear
            
    End If

Next

Application.ScreenUpdating = 1

If err_str <> "" Then
    MsgBox "Sheets: " & Chr(10) & Chr(10) & err_str & Chr(10) & " were not found and thus not processed.", vbCritical
Else
    MsgBox "All three sheets have been successfully processed", vbInformation
End If

End Sub

Hope this helps.