VBA: Copy cell from all worksheets and paste into column - vba

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