为每一列创建一个新工作表 header

Question

对于每一列 header，抓取每一列中的数据并创建一个包含单行数据的新工作表

为了澄清和提供更多上下文，我目前有一个 table 格式如下：

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

我想要实现的是：

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)

希望这提供了足够的上下文来解决问题。

Answer 1

创建 Header 个工作表

这只是一个基本示例。 table（headers 的一行）必须是连续的（没有空行或空列）并且必须从单元格 A1.
调整常量部分中的值。

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

为每一列创建一个新工作表 header

create a new worksheet for each column header

excel

vba

worksheet

创建 Header 个工作表