Создайте отдельные листы для каждой строки плюс заголовки, транспонированные

Question

Я новичок в VBA и пробовал несколько вариантов того, что я пытаюсь выполнить sh, но пока безуспешно. Я использую excel для ma c 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