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

[Dontik]

Hi

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

Claim_number	Model	Name	Value
zyx	a	b	1
pol	c	d	2

<tbody>
</tbody>

Claim_number	Model	Address	Value
qwe	e	ab	1
asd	f	cd	2
zzd	g	ef	3

<tbody>
</tbody>

Claim_number	Model	Address	Value
oko	h	gh	1
klo	i	ij	2

<tbody>
</tbody>

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:

Claim_number	Model	Name	Value
zyx	a	b	1
pol	c	d	2

<tbody>
</tbody>

Worksheet2:

Claim_number	Model	Address	Value
qwe	e	ab	1
asd	f	cd	2
zzd	g	ef	3

<tbody>
</tbody>

Worksheet3:

Claim_number	Model	Address	Value
oko	h	gh	1
klo	i	ij	2

<tbody>
</tbody>

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;">

Claim_number	Model	Address	Value
qwe	e	ab	1
asd	f	cd	2
zzd	g	ef	3

<tbody>
</tbody>

</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