复制一个单元格并向下粘贴一列

Question

一直在试图弄清楚如何从工作表 A 中复制一个单元格并将其粘贴到工作表 B 中的一列中，直到它与相邻列的行数相同。以下面的屏幕截图为例。我将如何在 VBA 中正确完成此操作？一段时间以来一直试图弄清楚这一点。我所能做的就是复制单元格并将其粘贴到相邻列中的最后一个单元格附近，而不是粘贴到整个列中。我从中复制数据的工作表如下图所示。

从下方的电子表格复制

粘贴到下方的电子表格

当前代码

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

如果您想在 VBA 中进行操作并希望在 "ALL" 列中复制一个值

Cells(1,1).Copy Columns(1)