Блог

Я работаю в VBA всего около 2 недель, поэтому мне нужна помощь. У меня есть настройка цикла для копирования 7 ячеек в рабочей книге (A), затем вставьте их вертикально в столбец в рабочей книге (B). По какой-то причине код работает, но не вставляет никаких данных… Некоторое время я безуспешно пытался устранить неполадки. Вот скриншот листа, с которого я копирую данные.

Вот скриншот рабочей книги, которую я тоже вставляю.

 Sub pullSecEquipment()

Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest 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 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
            
            '''
            '' Equipment Hours
            '''
            Dim range1 As Range
            Set range1 = Range("E:K")
            
            
        If shtDest.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
            

            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, 1).End(xlUp).Row   1)
            
            CopyRng.Copy
            DestRng.PasteSpecial Transpose:=True
            Application.CutCopyMode = False 'Clear Clipboard
            
            i = i   2
            
            Next i
          

        End If
        End If
        
    Filename = Dir()
Loop

MsgBox "Done!"
 

End Sub