VBA: Copy cell from all worksheets and paste into column

Question

New in VBA and learning on my own. The intent for the code below is to copy cell "D5" from every sheet in workbook and then paste all the data in workbook "Data", range D4:D300 (the range is pretty broad so it will have more cell available than cells copied). The problem is that the code below is not working. All the code is doing is coping cell D5 from the first sheet over the range indicated (D4:D300). Basically copying the same value 266 times. Any help is highly appreciated. If there is a more elegant/efficient way to write this code, please advise.

Sub copycell()

    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("Data")

    ' Loop through worksheets that start with the name "20"

    For Each sh In ActiveWorkbook.Worksheets

                ' Specify the range to copy the data

        sh.Range("D5").Copy


        ' Paste copied range into "Data" worksheet in Column D

        With DestSh.Range("D4:D300")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With


    Next

End Sub

Answer 1

You don't need to specify an end range -- just 'count' the number of sheets to determine the total # of values you'll need to add to the data tab. Also added in a check to see if you're on the Data worksheet so you don't copy the D5 value from Data again into a row in the same worksheet.

Sub copycell()

    Dim sh As Worksheet
    Dim wb As Workbook
    Dim DestSh As Worksheet
    Dim i As Integer

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

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

    ' Loop through worksheets that start with the name "20"
    i = 4
    For Each sh In ActiveWorkbook.Worksheets
    If sh.Name = "Data" Then Exit Sub
        sh.Range("D5").Copy
        With DestSh.Range("d" & i)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    i = i + 1

    Next

End Sub

Answer 2

On each pass through your ActiveWorkbook.Worksheets loop, paste into the cell below the last cell in column D unless D4 is blank, in which case paste in D4. I'm assuming column D is completely blank before running the macro but if D3 has something in it you can do away with the .Range("D4") = "" test.

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

    On Error GoTo GracefulExit:
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Data")
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> "Data" Then
            sh.Range("D5").Copy
            ' Paste copied range into "Data" worksheet in Column D
            ' starting at D4
            With DestSh
                If .Range("D4") = "" Then
                    With .Range("D4")
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                Else
                    With .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                End If
            End With
        End If
        Application.CutCopyMode = False
    Next
GracefulExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    If Err <> 0 Then
        MsgBox "An unexpected error no. " & Err & ": " _
        & Err.Description & " occured!", vbExclamation
    End If
End Sub

Answer 3

if you are more concerned about values, then a more concise code could be the following:

Option Explicit

Sub copycell()
    Dim sh As Worksheet
    Dim iSh As Long

    With ThisWorkbook
        ReDim dataArr(1 To .Worksheets.Count - 1)
        For Each sh In .Worksheets
            If sh.Name <> "Data" Then
                iSh = iSh + 1
                dataArr(iSh) = sh.Range("D5").Value
            End If
        Next
        .Worksheets("Data").Range("D4").Resize(.Worksheets.Count - 1).Value = Application.Transpose(dataArr)
    End With
End Sub

where you first store all sheets D5 cell values into an array and then write them in one shot into Data worksheet