Format each group of three columns as Tables

[apurcell]

Hello All,
I currently have a workbook with 3 sheets
Sheet 1: I use the =FILTER() Function to filter the data into only 3 columns for better presentation. Each set of data (the three columns) is presented in Cells A7:C100, D7:G100. I7:K100 etc. The last set is on GK7:GM100.
Sheet 2: Is the logic for how I would like to break out the data
Sheet 3: is all of the Data
I would like to create a MACRO that would take Sheet 1, create a duplicate, copy/paste as values (to remove the formulas) and then format each of these ranges (A7:C100, D7:G100. I7:K100 etc.) into Individual tables for further filtering if required.
Please let me know if this is possible!
Thank you so much

 

[maabadi]

When You Use filter, Hide Entire row of Unwanted Data. Then if you want Filter One Table with, Other Tables with same Row but Different Column, will be effected.

 

[apurcell]

When You Use filter, Hide Entire row of Unwanted Data. Then if you want Filter One Table with, Other Tables with same Row but Different Column, will be effected.

Yes I didn't think about that. What if instead it is a macro to split each table into its own sheet?

 

[maabadi]

I think you can Create Index Sheet to Link Tables. And it is better to transfer tables to each 100 rows.
Table 2 form row 107 to 200
Table 3 from row 207 to 300 And ...
Or transfer to sheets also.
Both of them Possible.

 

[maabadi]

Try This:

Sub TransformData()
Dim i As Long, Lr As Long, j As Long, Cell As Range, Lc As Long, L As Long, K1 As Long
Dim Lr2 As Long, Sh1 As Worksheet, Sh2 As Worksheet, Ws As Worksheet, LinkName As String
Dim IndexSH As String, LinkName2 As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
    'Create an Index Sheet. If already existing, clear it.
    On Error Resume Next
    Set Ws = Worksheets("Index")
    If Err.Number = 0 Then
        Worksheets("Index").ClearContents
        Else
        On Error GoTo 0
        Worksheets.Add(Before:=Worksheets(1)).Name = "Index"
    End If
    Worksheets("Index").Activate
    Range("A1") = "Index"
    Range("A1").Font.Bold = True
    Range("A1").Font.Size = 20
    
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Lc = Sh1.Cells(7, Columns.Count).End(xlToLeft).Column
IndexSH = "Index!A1"
For j = 1 To Lc Step 3
Range(Sh2.Cells(Int(j / 3) * 100 + 7, 1), Sh2.Cells((Int(j / 3) + 1) * 100, 3)).Value = Range(Sh1.Cells(7, j), Sh1.Cells(100, j + 2)).Value
Sh2.ListObjects.Add(xlSrcRange, Sh2.Range(Sh2.Cells(Int(j / 3) * 100 + 7, 1), Sh2.Cells((Int(j / 3) + 1) * 100, 3)), , xlYes).Name = "Table" & Int(j / 3) + 1
Sh2.ListObjects("Table" & Int(j / 3) + 1).TableStyle = "TableStyleLight1"
LinkName = "Sheet2!A" & Int(j / 3) * 100 + 7
Set LinkName2 = Range("Sheet2!E" & Int(j / 3) * 100 + 7)
Worksheets("Index").Range("A" & Int(j / 3) + 2).Value = "Table" & Int(j / 3) + 1
Ws.Hyperlinks.Add Anchor:=Range("A" & Int(j / 3) + 2), Address:="", SubAddress:=LinkName, TextToDisplay:="Table" & Int(j / 3) + 1
Sh2.Hyperlinks.Add Anchor:=LinkName2, Address:="", SubAddress:=IndexSH, TextToDisplay:="INDEX Sheet"
Next j

Worksheets("Index").Columns(1).AutoFit
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub