How to split table in excel

[siamandm]

Hello All,
If I have a table in excel, and want to split it based on ID with the header of the table as shown below, how to make this automatically and split information for each person in a separate table like below:

split table in excel.png

[snb]

Do not split tables.
Use a filter to filter information in a table.

[HansV]

Here is a way to do it:

Code: Select all

Sub SplitTable()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim tbs As ListObject
    Dim ids As Collection
    Dim cel As Range
    Dim rt As Long
    Dim id As Variant
    Application.ScreenUpdating = False
    Set wss = ActiveSheet
    Set tbs = wss.Range("A1").ListObject
    Set ids = New Collection
    On Error Resume Next
    For Each cel In tbs.ListColumns("Employee ID").DataBodyRange
        ids.Add Key:=CStr(cel.Value), Item:=cel.Value
    Next cel
    On Error GoTo 0
    Set wst = Worksheets.Add(After:=wss)
    wst.Range("Z1").Value = "Employee ID"
    rt = 1
    For Each id In ids
        tbs.HeaderRowRange.Copy Destination:=wst.Range("A" & rt)
        wst.Range("Z2").Value = id
        tbs.Range.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=wst.Range("Z1:Z2"), _
            CopyToRange:=wst.Range("A" & rt + 1)
        wst.Range("A" & rt).CurrentRegion.Rows(1).Delete Shift:=xlShiftUp
        wst.ListObjects.Add Source:=wst.Range("A" & rt).CurrentRegion
        rt = rt + wst.Range("A" & rt).CurrentRegion.Rows.Count + 1
    Next id
    wst.Range("Z1:Z2").Clear
    wst.UsedRange.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

[siamandm]

Thank you very much Hans,
this is really amazing :)

Regards

[YasserKhalil]

Thanks a lot, my tutor Hans for the perfect solution.
Another way

Code: Select all

Sub Test()
    Const sResult As String = "Result", StartRow As Long = 3, RowsToInsert As Long = 2
    Dim ky, vKey, ws As Worksheet, wsResult As Worksheet, tbl As ListObject, dict As Object, tblResult As Object, i As Long, j As Long
    Application.ScreenUpdating = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Sheets("Sheet1")
        Set tbl = ws.ListObjects(1)
        Application.DisplayAlerts = False
            On Error Resume Next
                ThisWorkbook.Worksheets(sResult).Delete
            On Error GoTo 0
        Application.DisplayAlerts = True
        Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        With wsResult
            .Name = sResult
            For i = 1 To tbl.Range.Rows.Count
                ky = tbl.DataBodyRange.Cells(i, 1).Value
                If Not dict.Exists(ky) Then dict.Add ky, New Collection
                dict(ky).Add tbl.DataBodyRange.Rows(i)
            Next i
            j = StartRow
            For Each vKey In dict.Keys
                If vKey <> Empty Then
                    tbl.HeaderRowRange.Copy Destination:=wsResult.Range("A" & j)
                    dict(vKey)(1).Resize(dict(vKey).Count, tbl.Range.Columns.Count).Copy Destination:=wsResult.Range("A" & j + 1)
                    Set tblResult = .ListObjects.Add(xlSrcRange, .Range("A" & j).Resize(dict(vKey).Count + 1, tbl.Range.Columns.Count), xlYes)
                    tblResult.Name = "Employee_" & vKey
                    .Range("A" & j + dict(vKey).Count + RowsToInsert).EntireRow.Insert
                    If j = StartRow Then tblResult.Range.EntireColumn.AutoFit
                    j = j + dict(vKey).Count + RowsToInsert + 1
                End If
            Next vKey
        End With
    Application.ScreenUpdating = True
End Sub

[hamster]

with Power Query

[snb]

I'd use:

Code: Select all

Sub M_snb()
   Sheet1.ListObjects(1).Range.Columns(1).AdvancedFilter 2, , Sheet1.Cells(1, 20), True
   sn = Sheet1.Cells(1, 20).CurrentRegion
   Sheet1.Cells(1, 20).CurrentRegion.Clear
   
   With Sheet1.ListObjects(1).Range
      For j = 2 To UBound(sn)
        .AutoFilter 1, sn(j, 1)
        .SpecialCells(12).Copy Sheet1.Cells(Rows.Count, 20).End(xlUp).Offset(2)
        .AutoFilter
      Next
   End With
   
   Sheet1.Cells(1, 20).Resize(2, Sheet1.ListObjects(1).Range.Columns.Count).Delete -4162
End Sub

[siamandm]

with Power Query

Dear Hamster,

Thank you very much for the support, could you please show me the steps how you did this please.

Regards

[siamandm]

I'd use:

Code: Select all

Sub M_snb()
   Sheet1.ListObjects(1).Range.Columns(1).AdvancedFilter 2, , Sheet1.Cells(1, 20), True
   sn = Sheet1.Cells(1, 20).CurrentRegion
   Sheet1.Cells(1, 20).CurrentRegion.Clear
   
   With Sheet1.ListObjects(1).Range
      For j = 2 To UBound(sn)
        .AutoFilter 1, sn(j, 1)
        .SpecialCells(12).Copy Sheet1.Cells(Rows.Count, 20).End(xlUp).Offset(2)
        .AutoFilter
      Next
   End With
   
   Sheet1.Cells(1, 20).Resize(2, Sheet1.ListObjects(1).Range.Columns.Count).Delete -4162
End Sub

Dear Snb Thank you very much for your useful codes

Regards

[hamster]

Thank you very much for the support, could you please show me the steps how you did this please

steps are :
data tab - show queries - double click on Table1 and you'll see basic steps on the right side
to see M for that go Home - Advanced Editor
to make separate, result tables, right click on the each table on the list and choose Add As New Query
then load each Query to the sheet

partition.png

[siamandm]

Thank you very much Hamster for the clarification, Now I know how to do it.
this is good for small data what if I have big data, I was not able to select multiple tables and then right-click and choose add as a new query, is there something we can do in this case?
the second question is: after creating queries and clicking Close&Load the tables went to separate sheets instead of one sheet, can we solve this also?


Regards

[hamster]

Power Query is just for BIG DATA
solution is tailored to your example

[siamandm]

in case we want to create 200 queries what will be the alternate solutions plz?

[hamster]

I am too lazy so check this one https://www.youtube.com/watch?v=Tnw77rpm-BQ

[siamandm]

thank you very much :)

[hamster]

you are welcome but you won't be too happy with this video

[siamandm]

Thanks a lot, my tutor Hans for the perfect solution.
Another way

Code: Select all

Sub Test()
    Const sResult As String = "Result", StartRow As Long = 3, RowsToInsert As Long = 2
    Dim ky, vKey, ws As Worksheet, wsResult As Worksheet, tbl As ListObject, dict As Object, tblResult As Object, i As Long, j As Long
    Application.ScreenUpdating = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Sheets("Sheet1")
        Set tbl = ws.ListObjects(1)
        Application.DisplayAlerts = False
            On Error Resume Next
                ThisWorkbook.Worksheets(sResult).Delete
            On Error GoTo 0
        Application.DisplayAlerts = True
        Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        With wsResult
            .Name = sResult
            For i = 1 To tbl.Range.Rows.Count
                ky = tbl.DataBodyRange.Cells(i, 1).Value
                If Not dict.Exists(ky) Then dict.Add ky, New Collection
                dict(ky).Add tbl.DataBodyRange.Rows(i)
            Next i
            j = StartRow
            For Each vKey In dict.Keys
                If vKey <> Empty Then
                    tbl.HeaderRowRange.Copy Destination:=wsResult.Range("A" & j)
                    dict(vKey)(1).Resize(dict(vKey).Count, tbl.Range.Columns.Count).Copy Destination:=wsResult.Range("A" & j + 1)
                    Set tblResult = .ListObjects.Add(xlSrcRange, .Range("A" & j).Resize(dict(vKey).Count + 1, tbl.Range.Columns.Count), xlYes)
                    tblResult.Name = "Employee_" & vKey
                    .Range("A" & j + dict(vKey).Count + RowsToInsert).EntireRow.Insert
                    If j = StartRow Then tblResult.Range.EntireColumn.AutoFit
                    j = j + dict(vKey).Count + RowsToInsert + 1
                End If
            Next vKey
        End With
    Application.ScreenUpdating = True
End Sub

Dear Yasser, thank you very much for your code, I would like to add or enable the total row for each table and put this function in it
=COUNTA([Clock-in/out Time])-COUNTBLANK([Clock-in/out Time])

[HansV]

Your sample workbook does not have a column Clock-in/out Time...

[siamandm]

Your sample workbook does not have a column Clock-in/out Time...

Dear Hans,
You are right, my apology for this, instead we can use Total Time column,

Regards
Siyamand

[HansV]

COUNTA counts non-blank cells, so I don't think you need to subtract COUNTBLANK.
Below the line

Code: Select all

                tblResult.Name = "Employee_" & vKey

insert these new lines:

Code: Select all

                tblResult.ShowTotals = True
                 tblResult.ListColumns("Total Time").TotalsCalculation = xlTotalsCalculationCount