为每一行加上页眉创建单独的工作表，转位。

Question

我是VBA的超级新手，我尝试了一些变化，我试图实现的东西，到目前为止没有运气。我使用的是excel for mac 16.37。

我有一个工作簿，其中包含约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