Скопировать диапазон на другой лист - PullRequest
Новая
       12

Скопировать диапазон на другой лист

2 голосов
/ 27 марта 2019

Я очень новичок в VBA и пытаюсь скопировать диапазон из закрытого файла Excel в активную книгу, не переопределяя текущий вставленный диапазон.

Это в Excel 2016. 

Sub GetDataFromWbs()
    Dim wb As Workbook
    Dim ws As Worksheet
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.Getfolder("C:\Path")
    Dim lastrow As Long

    For Each wbFile In fldr.Files
        If fso.GetExtensionName(wbFile.Name) = "xlsx" Then
            Set wb = Workbooks.Open(wbFile.Path)
            For Each ws In wb.Sheets
                ThisWorkbook.Activate
                Worksheets("Sheet1").Range("A1:D12").Formula = wb.Worksheets("Sheet1").Range("a1:c3").Formula  
                'here is where I would like to add +1 so my loop isn't overridden   
            Next 'ws
            wb.Close
        End If
    Next 'wbFile
End Sub

1 Ответ

2 голосов
/ 27 марта 2019

Я думаю, что-то вроде этого может быть то, что вы ищете.Я добавил комментарии к коду, чтобы помочь объяснить это. 

Sub tgr()

    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim rCopy As Range
    Dim sFolder As String
    Dim sFile As String
    Dim lRow As Long

    Set wbDest = ThisWorkbook                   'The workbook where information will be copied into
    Set wsDest = wbDest.Worksheets("Sheet1")    'The worksheet where information will be copied into
    sFolder = "C:\Test\"                        'The folder path containing the xlsx files to copy from
    lRow = 1                                    'The starting row where information will be copied into

    'Adjust the folder path to ensure it ends with \
    If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"

    'Get the first .xlsx file in the folder path
    sFile = Dir(sFolder & "*.xlsx")

    'Begin loop through each file in the folder
    Do While Len(sFile) > 0

        'Open the current workbook in the folder
        With Workbooks.Open(sFolder & sFile)
            'Copy over the formulas from A1:C3 from only the first worksheet into the destination worksheet
            Set rCopy = .Sheets(1).Range("A1:C3")
            wsDest.Cells(lRow, "A").Resize(rCopy.Rows.Count, rCopy.Columns.Count).Formula = rCopy.Formula

            'Advance the destination row by the number of rows being copied over
            lRow = lRow + rCopy.Rows.Count

            .Close False    'Close the workbook that was opened from the folder without saving changes
        End With
        sFile = Dir 'Advance to the next file
    Loop

End Sub
...