How to split table in excel

[otto1234]

Hi, this thread is a bit old, but I was wondering if this solution from Hans could be adapted to put each created table beside each other instead of below each other?

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

[HansV]

Welcome to Eileen's Lounge! I'll take a look later today.

[HansV]

Here is a version of the macro that will place the individual tables next to each other:

Code: Select all

Sub SplitTable()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim wsc As Worksheet
    Dim tbs As ListObject
    Dim ids As Collection
    Dim cel As Range
    Dim ct 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)
    Set wsc = Worksheets.Add
    wsc.Range("A1").Value = "Employee ID"
    ct = 1
    For Each id In ids
        tbs.HeaderRowRange.Copy Destination:=wst.Cells(1, ct)
        wsc.Range("A2").Value = id
        tbs.Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CriteriaRange:=wsc.Range("A1:A2"), _
                CopyToRange:=wst.Cells(2, ct)
        wst.Cells(1, ct).CurrentRegion.Rows(1).Delete Shift:=xlShiftUp
        wst.ListObjects.Add Source:=wst.Cells(1, ct).CurrentRegion
        ct = ct + wst.Cells(1, ct).CurrentRegion.Columns.Count + 1
    Next id
    wst.UsedRange.EntireColumn.AutoFit
    Application.DisplayAlerts = False
    wsc.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub