對于每個列標題，獲取每列中的資料并創建一個包含單行資料的新作業表
為了澄清并提供更多背景資訊，我目前有以下格式的表格：
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)
希望這提供了足夠的背景關系來解決問題。
uj5u.com熱心網友回復：
創建標題作業表
- 這只是一個基本的例子。表格（一行標題）必須是連續的（沒有空的行或列）并且它必須從 cell 開始
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/398069.html
上一篇：在Excel中用條件除法
下一篇：壓縮“If陳述句”中的重復代碼