VBA - How to split one worksheet containing small datasets into multiple worksheets

[Dontik]

Hi

I have a worksheet containing several small datasets, example below:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Name[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]zyx[/TD]
[TD]a[/TD]
[TD]b[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]pol[/TD]
[TD]c[/TD]
[TD]d[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Address[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]qwe[/TD]
[TD]e[/TD]
[TD]ab[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]asd[/TD]
[TD]f[/TD]
[TD]cd[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]zzd[/TD]
[TD]g[/TD]
[TD]ef[/TD]
[TD]3[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Address[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]oko[/TD]
[TD]h[/TD]
[TD]gh[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]klo[/TD]
[TD]i[/TD]
[TD]ij[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]

So that's how my worksheet looks like. I would like it to be split into multiple (three according to this example) worksheets. I thought it could be done by splitting if a certain column name is found, for example if vba encounters cell with a value "Claim_number", it transfers column names and below rows to a different worksheet. Or it could be done by splitting if there's a blank row between these small datasets. I just want something like that:

Worksheet1:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Name[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]zyx[/TD]
[TD]a[/TD]
[TD]b[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]pol[/TD]
[TD]c[/TD]
[TD]d[/TD]
[TD]2
[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet2:


[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Address[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]qwe[/TD]
[TD]e[/TD]
[TD]ab[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]asd[/TD]
[TD]f[/TD]
[TD]cd[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]zzd[/TD]
[TD]g[/TD]
[TD]ef[/TD]
[TD]3
[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet3:


[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Address[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]oko[/TD]
[TD]h[/TD]
[TD]gh[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]klo[/TD]
[TD]i[/TD]
[TD]ij[/TD]
[TD]2
[/TD]
[/TR]
</tbody>[/TABLE]

Any ideas how to do that?

Thank you in advance!


****** id="cke_pastebin" style="position: absolute; top: 0px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">[TABLE="width: 500"]
<tbody>[TR]
[TD]Claim_number[/TD]
[TD]Model[/TD]
[TD]Address[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]qwe[/TD]
[TD]e[/TD]
[TD]ab[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]asd[/TD]
[TD]f[/TD]
[TD]cd[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]zzd[/TD]
[TD]g[/TD]
[TD]ef[/TD]
[TD]3[/TD]
[/TR]
</tbody>[/TABLE]
</body>

 

[Roxxien]

Welcome on the forum,

Are all your small database with the same number of column?
Do you have a preference for which name to attribute to each tab?

 

[Dontik]

Thank you!

They have different structure, some columns are in all of those small datasets, but some are not.

Not exactly.

 

[Roxxien]

Hello, I made this and I think it will do what you want, however it's REALLY slow ...

I tries to use the line in commentary as it will accelerate but I have a problem with it.

I will try to solve it myself, but if anyone who read this know how to solve it, you are welcome to help.

Plz try this in a copy of your workbook.

Sub SmallDataBase()
Dim r As Range
Dim ws As Worksheet
Dim s As String
Dim i As Integer
Dim c As Currency


s = "SmallData"
Set ws = ActiveSheet
For Each r In Intersect(ws.UsedRange.Cells, ws.Range("A:A"))
    If r = "Claim_number" Then
        Sheets.Add After:=ActiveSheet
        i = i + 1
        ActiveSheet.Name = s & i
        c = 1
    Else
        c = c + 1
    End If
    ws.Rows(r.Row).Copy ActiveSheet.Cells(c, 1)
    'ws.Range(r, Cells(r.Row, Cells(1, Columns.Count).End(xlToLeft).column)).Copy ActiveSheet.Cells(c, 1)
Next
End Sub

 

[MrKowz]

This code assumes there is a single blank row between each dataset and your data begins in column A. If this is not the case, please describe what defines a separation between datasets, and I can amend.

Public Sub SplitDataSet()
Dim i           As Long, _
    LR          As Long
    
Dim StartRow    As Long, _
    EndRow      As Long
    
Dim sWS         As Worksheet, _
    dWS         As Worksheet
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Set sWS = ActiveSheet
LR = sWS.Range("A" & Rows.Count).End(xlUp).Row
StartRow = 1
For i = 2 To LR + 1
    If sWS.Range("A" & i).Value = "" Then
        EndRow = i - 1
        Set dWS = Sheets.Add
        sWS.Range("A" & StartRow & ":A" & EndRow).EntireRow.Copy Destination:=dWS.Range("A1")
        Set dWS = Nothing
        StartRow = i + 1
    End If
Next i

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub