Spliting an Excel worksheet by tables onto new Worksheets

Adam Jar 0
Viewed 48

I am trying to split one, long worksheet with tables of variable height, but fixed length onto separate worksheets for each table, if possible, without the cell size change.

This is how it looks like, I marked how i need these to be separated. They aren't actually Excel tables, and I cannot alter the original file structure. I need it to be a "just works" macro.

They all start with a "Kod:XXXX" cell and a "Suma:" cell, I figured these could do as separators of where to start and where to end.

This is the code I found, it works fine, but requires the user to pick headers, content and split row manually, one by one.

I Figured out how it should (probably) be structured, but I do not know how to do certain things.

Sub Podziel_na_arkusze()
    Dim WorkRng As Range
    Dim xRow As Range
    Dim SplitRow As Integer
    Dim xWs As Worksheet
    Dim xTRg As Range
    Dim xNTRg As Range
    Dim xIER

    On Error Resume Next
'All this are things I do not want; I need it to be as automatic as possible
'    xTitleId = "Podziel na arkusze"
'    Set WorkRng = Application.Selection
'    Set xTRg = Application.InputBox("Please select the header row:", xTitleId, "", Type:=8)
'        If TypeName(xTRg) = "Nothing" Then Exit Sub
'    Set WorkRng = Application.InputBox("Please select the data range(exclude the header 'row):", xTitleId, WorkRng.Address, Type:=8)
'        If TypeName(WorkRng) = "Nothing" Then Exit Sub
'    SplitRow = Application.InputBox("Split Row Num", xTitleId, Type:=1)
'        If SplitRow = 0 Then Exit Sub
' I left stuff I can't figure out empty
    Set WorkRng = ("(cell left to Kod cell):(2 cells below "Tel:")
    Set xTRg = ("(the "Kod" cell):(the "Suma" cell)")
    Set SplitRow = "(any cell of each table, it doesn't matter since they are horizontal) 
    Set xWs = WorkRng.Parent
    Set xRow = WorkRng.Rows(1)
    xIER = WorkRng.Rows.Count
    xIER = WorkRng.Row + xIER - 1
    Application.ScreenUpdating = False
    For i = 1 To WorkRng.Rows.Count Step SplitRow
        resizeCount = SplitRow
        If (xIER - xRow.Row + 1) < SplitRow Then
            resizeCount = (xIER - xRow.Row + 1)
        End If
            xRow.Resize(resizeCount).Copy
        Set xWs = Application.Worksheets.Add(after:=Application.Worksheets(Application.Worksheets.Count))
        If xIER > (xRow.Row + SplitRow - 1) Then
            xWs.Name = xRow.Row & " - " & (xRow.Row + SplitRow - 1)
            ElseIf xIER = xRow.Row Then
                xWs.Name = xRow.Row
            Else
                xWs.Name = xRow.Row & " - " & xIER
        End If
        Application.ActiveSheet.Range("A1").PasteSpecial
        Set xNTRg = Application.ActiveSheet.Range("A1")
        xTRg.Copy
        xNTRg.Insert
        Set xRow = xRow.Offset(SplitRow)
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

How would I get it to automatically detect cells with "kod" and "suma" in them, and loop it till last table has been separated? (and, if possible, make it so cell sizes stay the same)

vba excel
1 Answers

You could use Find(), similar to (untested):

Sub test()
    With Sheets(1)
        Dim lastRow As Long:  lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim i As Long
        For i = 1 To lastRow
            Dim firstFindValue As String:  firstFindValue = "KOD"
            Dim firstFoundCell As Range:  Set firstFoundCell = .Range(.Cells(i, 1), .Cells(lastRow, 1)).Find(what:=firstFindValue, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
            If firstFoundCell Is Nothing Then
                Exit For
            Else
                Dim secondFindValue As String:  secondFindValue = "Suma"
                Dim secondFoundCell As Range:  Set secondFoundCell = .Range(.Cells(firstFoundCell.Row + 1, 1), .Cells(lastRow, 1)).Find(what:=secondFindValue, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
                If secondFoundCell Is Nothing Then Exit For
                Dim destinationSheet As Worksheet:  Set destinationSheet = ThisWorkbook.Sheets.Add
                .Range(.Rows(firstFoundCell.Row),.Rows(secondFoundCell.Row)).Copy destinationSheet.Cells(1,1)
                i = secondFoundCell.Row
                Set firstFoundCell = Nothing
                Set secondFoundCell = Nothing
            End If
        Next i
    End With
End Sub

Edit1: Updated per Toddleson's comments.

userDazd0
Related