Copiar em VBA o valor de multiplos arquivos [EXCEL]

[andre_luis]

Ok, mas como mencionei antes, são cerca de 60 planilhas, e eu teria de repetir esse processo manual para cada uma delas, e sinceramente, não acho que seja um retrocesso fazer com esse recurso, pelo contrário, as funções do Excel não atendem á todas as necessidades.

[andre_luis]

Depois de algum tempo, consegui fazer a coisa funcionar.
O problema é que eu estava usando o método Activate, que pra quem não o domina, avacalha com tudo.

Pra quem interessar, segue um rabisco funcional abaixo.
Depois se tiver tempo, boto uns comentários pra ajudar a entender.

vbnet code

Sub ImportarDadosSemAbrir()

    Dim sExtensionOrigin      As String
    Dim sPathOrigin           As String
    Dim sFileOrigin           As String
    Dim sSheetOrigin          As String
    Dim sRangeOrigin          As String
    Dim sColumnOrigin         As String
    Dim sYearOrigin           As String
    Dim sMonthOrigin          As String
    Dim sExtensionDestination As String
    Dim sPathDestination      As String
    Dim sFileDestination      As String
    Dim sSheetDestination     As String
    Dim sRangeDestination     As String
    Dim sColumnDestination    As String
    
    Dim iIndexFile            As Integer
    Dim iRow                  As Integer
    Dim iColumn               As Integer
    Dim iCountData            As Integer
    Dim iRowDestination       As Integer
    Dim iFirstMont            As Integer
    Dim iLastMonth            As Integer
    
    Dim lLastRow              As Long
    
    Dim wkb                   As Workbook
    Dim shReference           As Worksheet
        
    ' define current application parameters
    iRow = 1
    iColumn = 1
    iCountData = 0
    iFirstMont = 4
    iLastMonth = 7
    
    sYearOrigin = "2014"
    sMonthOrigin = "04"
    sExtensionOrigin = ".xlsx"
    sPathOrigin = "C:\Andre\CR\"
    sSheetOrigin = "Plan3"
    sRangeOrigin = "b14"
    sPathDestination = PathOrigin
    sSheetDestination = "Plan1"
    sColumnDestination = "C"
    
    'lock screen update, turning overall processing somewhat faster
    Application.ScreenUpdating = False
      
    Set shReference = Sheets(sSheetDestination)
    ' get the last filled cell
    lLastRow = shReference.Cells(Rows.Count, sColumnDestination).End(xlUp).Row
    ' define the first cell address to store as being the last one filled
    iRowDestination = lLastRow
    ' Scan cell of interest within each sheet read, and paste it value to the current free cell
    For iIndexFile = iFirstMont To iLastMonth
        sFileOrigin = "R_" & sYearOrigin & "0" & CStr(iIndexFile) & sExtensionOrigin
        Set wkb = Workbooks.Open(Filename:=sPathOrigin & sFileOrigin, ReadOnly:=True)
        With wkb.Sheets(sSheetOrigin).Range(sRangeOrigin).Copy
            ThisWorkbook.Sheets(sSheetDestination).Range(sColumnDestination & CStr(iRowDestination + iIndexFile - iFirstMont + 1)).PasteSpecial xlPasteValues
        End With
        iColumn = iColumn + 1
        iCountData = iCountData + 1
        wkb.Close SaveChanges:=False
        ' Application.Quit
    Next iIndexFile
    ' allow screen update
    Application.ScreenUpdating = True
    ' inform amount of succedded copies
    MsgBox "Copied " & CStr(iCountData) & " values!", vbInformation, "Information"
End Sub

[EDITADO]

Aqui, uma revisão da versão acima, agora com esteróides...

vbnet code

Sub CopyValuesFromMultipleFilesAndAppendToCurrentSheet()

    Dim sPathOrigin           As String
    Dim sSheetOrigin          As String
    Dim sRangeOrigin          As String
    Dim sSheetDestination     As String
    Dim sColumnDestination    As String
    
    Dim iRow                  As Integer
    Dim iColumn               As Integer
    Dim iCountData            As Integer
    Dim iRowDestination       As Integer
    Dim lLastRow              As Integer
    
    Dim wkb                   As Workbook
    Dim shReference           As Worksheet

    Dim fso                   As Object
    Dim objFiles              As Object
    Dim obj                   As Object
    Dim lngFileCount          As Long
         
    ' define current application parameters
    iRow = 1
    iColumn = 1
    iCountData = 0
    
    sPathOrigin = "C:\Andre\CR\"
    sSheetOrigin = "Plan3"
    sRangeOrigin = "b14"
    sSheetDestination = "Plan1"
    sColumnDestination = "C"
       
    ' Create a variable of the type 'Object'
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the list names of the files present at origin folder
    Set objFiles = fso.GetFolder(sPathOrigin).Files
    ' Get amount of files existing at origin folder
    lngFileCount = objFiles.Count
    
    ' lock screen update, turning overall processing somewhat faster
    Application.ScreenUpdating = False
    ' get the last cell filled at the column where values will be stored
    lLastRow = Sheets(sSheetDestination).Cells(Rows.Count, sColumnDestination).End(xlUp).Row
    ' define the first cell address to store as being the last one filled
    iRowDestination = lLastRow
    ' Scan cell of interest within each sheet read, and paste it value to the current free cell
    For Each SpreadSheet In fso.GetFolder(sPathOrigin).Files
        ' Check if file type is spreadsheet, otherwise skip
        If InStr(1, SpreadSheet, ".xl") = 0 Then GoTo SKIP_TO_HERE
            ' Define used area of the sheet to autosize according to cell content
            Worksheets(sSheetDestination).Columns("A:D").AutoFit
            ' Open current file of the origin folder
            Set wkb = Workbooks.Open(Filename:=SpreadSheet, ReadOnly:=True)
            ' Copy cells of interest to clipboard
            With wkb.Sheets(sSheetOrigin).Range(sRangeOrigin).Copy
                ' Paste copied cells to destination cells
                ThisWorkbook.Sheets(sSheetDestination).Range(sColumnDestination & CStr(iRowDestination + iCountData + 1)).PasteSpecial xlPasteValues
            End With
            ' Append a header cell containing the name of file from where cells were copied, shifted 1 column form values fields
            ThisWorkbook.Sheets(sSheetDestination).Cells(iRowDestination + iCountData + 1, sColumnDestination).Offset(, -1).Value = Replace(SpreadSheet, sPathOrigin, "")
            ' Increment index
            iCountData = iCountData + 1
            ' Close each file opened, just after copy/paste operation has finished
            wkb.Close SaveChanges:=False
SKIP_TO_HERE:
    Next
    ' allow screen update
    Application.ScreenUpdating = True
    ' inform amount of succedded copies
    MsgBox "Copied " & CStr(iCountData) & " values!", vbInformation, "Information"
    ' Application.Quit
End Sub