时间戳

首页 > 解决方案 > 为每一行加上标题创建单独的工作表，转置

excel - 为每一行加上标题创建单独的工作表，转置

问题描述

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

我有一个工作簿，其中包含大约 93 个数据点的列，这些数据点代表来自客户数据库的状态更新评估。每行代表一个状态更新评估。我们的数据库供应商没有为客户打印单独评估的本地方法，因此我正在尝试创建一个宏，如果他们要求打印副本，我将允许我打印客户的所有评估。

可以在这里查看一个示例，这是我手动完成的：

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

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

标签： excelvbamacos

解决方案

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

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

推荐阅读