For each column header, grab the data in each column and create a new worksheet with the data in a single row

To clarify and provide more context, I currently have a table in the format below:

Header A | Header B | ...
--------------------------
Data A1  | Data B1  | ...
Data A2  | Data B2  | ...
...

What I want to achieve is the following:

For each column header
  Create a new worksheet with the header name
  Fill the worksheet with the following table:
    Data A1 | Data A2 | Data A3 | ... (tldr, for each header, get data and create a table where 
    the headers of the new table are the data relevant to the specific header)

Hopefully, this provides enough context to address the problem.

CodePudding user response：

Create Header Worksheets

• This is just a basic example. The table (one row of headers) has to be contiguous (no empty rows or columns) and it has to start in cell A1.
• Adjust the values in the constants section.

Option Explicit

Sub CreateHeaderWorksheets()
    
    Const sName As String = "Sheet1" ' Source Worksheet Name (has table)
    Const dfCellAddress As String = "A1" ' Destination Worksheets First Cell
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim rCount As Long: rCount = srg.Rows.Count - 1 ' minus headers
    
    Dim dws As Worksheet
    Dim scrg As Range
    Dim dName As String
    
    For Each scrg In srg.Columns
        dName = CStr(scrg.Cells(1).Value) ' header
        On Error Resume Next
        Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If Not dws Is Nothing Then ' delete if it exists
            Application.DisplayAlerts = False ' delete without confirmation
            dws.Delete
            Application.DisplayAlerts = True
        End If
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)) ' new
        dws.Name = dName
        dws.Range(dfCellAddress).Resize(, rCount).Value _
            = Application.Transpose(scrg.Resize(rCount).Offset(1).Value) ' write
        Set dws = Nothing ' reset because in loop
    Next scrg
    
    sws.Select
    
    MsgBox "Worksheets created.", vbInformation
    
End Sub