为每行和标题创建单独的工作表，转置

Question

我是 VBA 的新手，并且已经尝试了一些我想要完成的事情的变化，但到目前为止没有运气。我在 mac 16.37 的 excel 上。

我有一个工作簿，其中包含大约 93 个数据点的列，表示来自客户端数据库的状态更新评估。每行表示一个状态更新评估。我们的数据库供应商没有为客户打印单独评估的本机方法，因此我正在尝试创建一个宏，以便在客户要求打印副本时打印所有评估。

可以在此处查看一个示例，这是我手动执行的操作：

• 在示例中有两个评估，因此我创建了两个选项卡，并将这些选项卡命名为评估日期。
• 两列左对齐
• 将"项目状态日期"移至首行，以便可以将其用作标题并打印在每页顶部
• 调整列宽

如果有一种方法可以复制每一行，转置，一个接一个，以便所有内容都在一个垂直工作表中，评估将一个接一个地打印，我也会对它感兴趣。

我知道这很模糊，但我希望这是一个我没有看到的简单修复，因为我对 VBA 太不熟悉了。我将不胜感激任何人的指点！

Answer 1

这段代码可能会解决你的问题，或者它可能会给你一个点：

Sub CreateSheetsAndCopyInfos()
Application.ScreenUpdating = False
Application.StatusBar = ""
Sheets("Source").Select
r = 2
Do Until Cells(r, "A").Value = "" ' Or whatever you think better
Application.StatusBar = "Create Sheet: P" & r
'Delete Old Sheet If exist
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name = "P" & r Then 'p for person , r is row number
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "P" & r
Sheets("Source").Select
Range(Cells(1, "A"), Cells(1, 93)).Select 'Header Row
Selection.Copy
Sheets("P" & r).Select 'Target
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Source").Select
Range(Cells(r, "A"), Cells(r, 93)).Select 'person Row
Selection.Copy
Sheets("P" & r).Select 'Target
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
r = r + 1
Loop
Application.ScreenUpdating = True
Application.StatusBar = ""
MsgBox "Done."
End Sub