Clean a excel-file create new WBs and split the data from the first WB

[TitoElan]

Hello! I am struggling with a problem. I have an Excel file with many sheets. Each sheet contains many tables with information. The tables have the same amount of rows.

I want to somehow create a new WB for each sheet from WB1 and inside de new WB a sheet for each table within a sheet from WB1.

Here is a sheet from WB1 as an example. The new workbook should contain the green table alone in a new worksheet with the name from cell B3. The next sheet is to contain the next red table, also with the first 2 rows and as sheet name GP = 24.1 and so on.

I only managed to do this for one range, but not even for a whole sheet.

Sub CopyRows()

' Declare variables
Dim srcWbk As Workbook
Dim srcSheet As Worksheet
Dim destWbk As Workbook
Dim destSheet As Worksheet
Dim rng As Range

' Set the source workbook and sheet
Set srcWbk = Workbooks("erzeugerpreise-lange-reihen-xlsx-5612401(2).xlsm")
Set srcSheet = srcWbk.Sheets("GP Nr. 24-25")

' Set the destination workbook
Set newWbk = Workbooks.Add
Set destWbk = Workbooks.Add

' Set the range of cells to copy
Set rng = srcSheet.Range("A3:N20")

' Copy the range of cells to the destination workbook
rng.Copy

' Insert a new sheet in the destination workbook
Set destSheet = destWbk.Sheets.Add

' Paste the copied cells into the new sheet
destSheet.Paste

' Rename the sheet based on the cell in the copied range
destSheet.Name = rng.Cells(1, 2).Value

End Sub

 

[TitoElan]

Ok I did it for one sheet. Now I am having probles using it for all sheet and creating a WB for each one

Sub SplitSheet()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rngToCopy As Range
Dim lastRow As Long

Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:Q" & lastRow)
Set rngToCopy = rng.Range("A1:Q20")

Do Until rngToCopy.Cells(1, 1) = ""
    Set ws2 = Sheets.Add
    rngToCopy.Copy Destination:=ws2.Range("A1")
    Set rngToCopy = rngToCopy.Offset(20, 0)
Loop

End Sub