Блог

Пытался выяснить, как скопировать ячейку с листа 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) amp; ""

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:" amp; Rows.Count).ClearContents


Filename = Dir(path amp; "*.xls*", vbNormal)

If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
        Set Wkb = Workbooks.Open(Filename:=path amp; "" amp; 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" amp; 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" amp; 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" amp; 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 amp; " " amp; 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
 

если вы хотите сделать это в VBA и хотите скопировать одно значение в столбец «ВСЕ»

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