резюме из различных (конкретных) рабочих листов на один рабочий лист

Question

Все, что я хочу сделать, в пределах одной и той же книги состоит в том, чтобы скопировать значение из ячейки B2 в несколько таблиц SELECTED и вставить в столбец D в другой рабочий лист под названием «Сводка». Кроме того, я хотел бы также скопировать и вставить соответствующее имя рабочего листа в столбце C. Это два кода, которые у меня до сих пор, оба не удалось, не знаю, как их исправить, не уверен, есть ли лучший способ сделать это , Я новичок в VBA. Я уверен, вы найдете глупые ошибки, пожалуйста, простите меня. Оба кода выходят из строя под «Ошибка времени выполнения» 5: Недопустимый вызов или аргумент процедуры ». Любая помощь высоко ценится.

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

Function LastCol(sh As Worksheet) 
    On Error Resume Next 
    LastCol = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Column 
    On Error GoTo 0 
End Function 

Sub CopyRangeFromMultiWorksheets() 
    Dim sh As Worksheet 
    Dim wb As Workbook 
    Dim DestSh As Worksheet 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    Set wb = ThisWorkbook 
    Set DestSh = wb.Sheets("Summary") 

    ' Loop through worksheets that start with the name "20" 
    ' This section I tested and it works 

    For Each sh In ActiveWorkbook.Worksheets 
     If LCase(Left(sh.Name, 2)) = "20" Then 

      ' Specify the range to copy the data 
      ' This portion has also been tested and it works 

      sh.Range("B2").Copy 

      ' Paste copied range into "Summary" worksheet in Column D 
      ' This is the part that does not work I get: 
      ' Run-time error '5' : Invalid procedure call or argument 

      With DestSh.Cells("D2:D") 
       .PasteSpecial xlPasteValues 
       .PasteSpecial xlPasteFormats 
       Application.CutCopyMode = False 
      End With 

      ' This statement will copy the sheet names in the C column. 
      ' I have not been able to check this part since I am stock in the previous step 
      DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name 

     End If 

    Next 

ExitTheSub: 

    Application.Goto Worksheets("Summary").Cells(1) 


    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 

Второй Код:

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

Function LastCol(sh As Worksheet) 
    On Error Resume Next 
    LastCol = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Column 
    On Error GoTo 0 
End Function 

Sub CopyRangeFromMultiWorksheets() 
    Dim sh As Worksheet 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 


    ' Loop through worksheets that start with the name "20" 
    ' This section I tested and it works 

    For Each sh In ActiveWorkbook.Worksheets 
     If LCase(Left(sh.Name, 2)) = "20" Then 

      ' Specify the range to copy the data 
      ' This portion has also been tested and it works 

      sh.Range("B2").Copy 

      ' Paste copied range into "Summary" worksheet in Column D 
      ' This is the part that does not work I get: 
      ' Run-time error '5' : Invalid procedure call or argument 

      Worksheets("Summary").Cells("D2:D").PasteSpecial (xlPasteValues) 

      ' This statement will copy the sheet names in the C column. 
      ' I have not been able to check this part works since I am stock in the previous step 
      Worksheets("Summary").Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name 



     End If 

    Next 

ExitTheSub: 

    Application.Goto Worksheets("Summary").Cells(1) 


    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 

Answer 1

Я внес изменения в свой первый код:

Sub CopyRangeFromMultiWorksheets() 
     Dim sh As Worksheet 
     Dim wb As Workbook 
     Dim DestSh As Worksheet 
     Dim LastRow As Long 

     With Application 
      .ScreenUpdating = False 
      .EnableEvents = False 
     End With 

     Set wb = ThisWorkbook 
     Set DestSh = wb.Sheets("Summary") 

     ' Loop through worksheets that start with the name "20" 
     ' This section I tested and it works 

     For Each sh In ActiveWorkbook.Worksheets 
      If LCase(Left(sh.Name, 2)) = "20" Then 

       ' Specify the range to copy the data 
       ' This portion has also been tested and it works 

       sh.Range("B2").Copy 

       LastRow = DestSh.Cells(Rows.Count, "D").End(xlUp).Row + 1 'find the last row of column "D" 

       ' Paste copied range into "Summary" worksheet in Column D 
       ' This is the part that does not work I get: 
       ' Run-time error '5' : Invalid procedure call or argument 

       'With DestSh.Cells("D2:D")  ----> this line is giving error 
       With DestSh.Cells(LastRow, 4) '----> 4 is for Column "D" 
        .PasteSpecial xlPasteValues 
        .PasteSpecial xlPasteFormats 
        Application.CutCopyMode = False 
       End With 

       ' This statement will copy the sheet names in the C column. 
       ' I have not been able to check this part since I am stock in the previous step 

       LastRow = DestSh.Cells(Rows.Count, "C").End(xlUp).Row + 1 'find the last row of column "C" 

       'DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name ----> this line is giving error 
       DestSh.Cells(LastRow, 3).Value = sh.Name     '----> 3 is for Column "C" 

      End If 
     Next 
    ExitTheSub: 
     Application.Goto Worksheets("Summary").Cells(1) 
     With Application 
      .ScreenUpdating = True 
      .EnableEvents = True 
     End With 
    End Sub