Как захватить дополнительную строку из различных листов

Question

Мне дали старый файл Excel с макросом, который копирует оценки и бронирования из всех листов этой книги в первый лист. Рабочие листы были дополнены дополнительными полями комментариев, и я попытался обновить макрос, чтобы он также отображал его на первом рабочем листе, но безрезультатно. Вот код:

sno = 1
lastcol = Sheets(1).Range("iv8").End(xlToLeft).Column


resrow = 9
headers = Array("Registration information", "CASE DETAILS (GENERAL) SCREEN", "Sender INFORMATION", "Client SCREEN", "PRODUCT", "Price")
For i = 2 To Sheets.Count
observ = ""
observno = 1
resrow = resrow + 1
rescol = 10
    lastrow = Sheets(i).Range("c65535").End(xlUp).Row
    Sheets(1).Cells(resrow, 1) = sno
    Sheets(1).Cells(resrow, 2) = Sheets(i).Range("d2")
    Sheets(1).Cells(resrow, 4) = Sheets(i).Range("d9")
    Sheets(1).Cells(resrow, 3) = Sheets(i).Range("d3")
    Sheets(1).Cells(resrow, 5) = Sheets(i).Range("d4")
    Sheets(1).Cells(resrow, 6) = Sheets(i).Range("d5")
    Sheets(1).Cells(resrow, 7) = Sheets(i).Range("E9")


            While rescol <= lastcol - 4
            For j = 9 To lastrow
            If Sheets(i).Cells(j, 3) <> "" Then
             Sheets(1).Cells(resrow, rescol) = Sheets(i).Cells(j, 3)
             If Sheets(i).Cells(j, 3) > 0 And j <> lastrow Then
                observ = observ & observno & ". " & Sheets(i).Cells(j, 4) & vbCrLf

                observno = observno + 1

             End If
             rescol = rescol + 1
             End If
             Next j
            Wend

    Sheets(1).Cells(resrow, 8) = observ
    sno = sno + 1
Next i
End Sub

Новое поле на листах называется комментариями, и я попытался скопировать и изменить эту часть

 While rescol <= lastcol - 4
            For j = 9 To lastrow
            If Sheets(i).Cells(j, 3) <> "" Then
             Sheets(1).Cells(resrow, rescol) = Sheets(i).Cells(j, 3)
             If Sheets(i).Cells(j, 3) > 0 And j <> lastrow Then
                commen = commen & commenno & ". " & Sheets(i).Cells(j, 4) & vbCrLf

                commenno = commenno + 1

Но безрезультатно.

Вот столбцы в главном листе (строка 9 в листе)

Вот пример других листов

Answer 1

Код, похожий на комментарии к тому, что у вас есть для наблюдений.

Option Explicit

Sub Consolidate()

    Dim sno As Long, lastrow As Long, lastcol As Long, resrow As Long, rescol As Long
    Dim observno As Integer, commentno As Integer, i As Long, j As Long
    Dim observ As String, comment As String
    Dim ws As Worksheet, wsRes As Worksheet

    Set wsRes = Sheets(1)
    sno = 1
    lastcol = wsRes.Range("iv8").End(xlToLeft).Column
    Debug.Print lastcol

    resrow = 9

    ' not sure what this is doing
    'headers = Array("Registration information", "CASE DETAILS (GENERAL) SCREEN", "Sender INFORMATION", "Client SCREEN", "PRODUCT", "Price")

    For i = 2 To Sheets.Count

        observ = ""
        comment = ""
        observno = 1
        commentno = 1
        resrow = resrow + 1
        rescol = 10

        ' determine last row by using Ctrl-Up from cell C1048576
        lastrow = Sheets(i).Range("C" & Rows.Count).End(xlUp).Row

        Set ws = Sheets(i)

        ' fill the current results columns1 to 6 from scorecard
        With wsRes.Cells(resrow, 1)
            .Offset(0, 0) = sno
            .Offset(0, 1) = ws.Range("D2")
            .Offset(0, 2) = ws.Range("D3")
            .Offset(0, 3) = ws.Range("D9")
            .Offset(0, 4) = ws.Range("D4")
            .Offset(0, 5) = ws.Range("D5")
            .Offset(0, 6) = ws.Range("E9")
            .VerticalAlignment = xlTop
        End With

        ' scan down scorecard sheet starting at row 9 (probably should be 11)
        Dim qu As Integer
        For j = 9 To lastrow

            qu = rescol - 9

            ' skip the group heading between questions
            If Trim(Sheets(i).Cells(j, 3)) <> "" Then
                ' transfer score to result sheet
                ' move to next col ready for next Qu
                wsRes.Cells(resrow, rescol) = Sheets(i).Cells(j, 3)
                rescol = rescol + 1
            End If

            ' all observation regardless of score
            ' trim removes any hidden leading spaces
            ' if scan starts at 11 remove the And j > 9
            If Trim(ws.Cells(j, 4)) <> "" And j > 9 Then
                ' start new line for 2nd, 3rd etc observation
                If Len(observ) > 0 Then observ = observ & vbCrLf
                observ = observ & qu & ". " & ws.Cells(j, 4)
                'observno = observno + 1
            End If

            ' all comments regardless except first row which is header
            If Trim(ws.Cells(j, 5)) <> "" And j > 9 Then
                If Len(comment) > 0 Then comment = comment & vbCrLf
                comment = comment & qu & ". " & ws.Cells(j, 5)
                'commentno = commentno + 1
            End If

        Next j

        wsRes.Cells(resrow, 8) = observ
        wsRes.Cells(resrow, 9) = comment
        sno = sno + 1
    Next i
    MsgBox Sheets.Count - 1 & " sheets scanned", vbInformation

End Sub