Copy one cell and paste down a column - vba

Question

Been trying to figure out how to copy a cell from worksheet A and paste it down a column in Worksheet B until it matches the same amount of rows as an adjacent column. Take the following screenshot for example. How would I properly accomplish this in VBA? Been trying to figure this out for a while now. All I've been able to do is copy the cell and paste it adjacent to the last cell in the adjacent column instead of down the entire column. The worksheet I'm copying data from is pictured below.
Copy From SpreadSheet down below
Paste to SpreadSheet down below
Current Code
Sub pullSecEquipment()
Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest As Worksheet
Dim shtPull As Worksheet
Dim Filename As String
Dim Wkb As Workbook
Dim CopyRng As Range, DestRng As Range
Dim lRow As Integer
Dim destLRow As Integer
Dim Lastrow As Long
Dim FirstRow As Long
Dim UpdateDate As String
ThisWB = ActiveWorkbook.Name
Dim selectedFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
selectedFolder = .SelectedItems(1) & "\"
End With
path = selectedFolder
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = Workbooks("GPnewchapterTEST2.xlsm").Worksheets("START")
'clear content of destination table
shtDest.Rows("8:" & Rows.Count).ClearContents
Filename = Dir(path & "\*.xls*", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'MsgBox Filename
'''''
'SEC
'''''
If InStr(Filename, "Equipment") <> 0 Then
Dim range1 As Range
Set range1 = Range("E:K")
'For Each Wkb In Application.Workbooks
'For Each shtDest In Wkb.Worksheets
'Set shtPull = Wkb.Sheets(1)
'If shtPull.Name Like "*-*" Then
'last row
destLRow = Wkb.Sheets(1).Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
'1st row
lRow = Wkb.Sheets(1).Cells.Find(what:="EQUIPMENT DESCRIPTION", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'STHours
Dim i As Integer
For i = lRow To destLRow
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 5).Address, Cells(i, 11).Address)
Set DestRng = shtDest.Range("O" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row + 1)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 1).Address, Cells(i, 1).Address)
Set DestRng = shtDest.Range("C" & shtDest.Cells(Rows.Count, "O").End(xlDown).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 3).Address, Cells(i, 3).Address)
Set DestRng = shtDest.Range("S" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
i = i + 2
Next i
'Dim cell As Integer
'Dim empname As String
'destLRow = 8 '' find out how to find first available row
'For cell = 2 To lRow
'empname = Wkb.Sheets(1).Cells(cell, 3).Value & " " & Wkb.Sheets(1).Cells(cell, 4).Value
' shtDest.Cells(8, 5).Value = empname
'shtDest.Cells(8, 1).Value = "Service Electric"
'Next cell
' Wkb.Close Save = False
End If
'End If
Filename = Dir()
Loop
MsgBox "Done!"
End Sub

Answer 1

if you want to do in VBA and want to copy one value in "ALL" column
Cells(1,1).Copy Columns(1)