Copy the contents of a spreadsheet and paste into a new one using VBA

Question

Good afternoon!

I need to create a code in VBA that copies the contents of several worksheets and paste into a specific worksheet. In case, it would have to have a repeat loop to open the sheets of a directory, copy and paste into a single final spreadsheet. You can help me?

Thanks in advance!

Answer 1

Vinicio Lima, good afternoon.

For this code to work correctly you must leave the various worksheets (workbooks) and the worksheet specifies (workbook) of destination in the same directory.

Run the 'transference'. I left as an example a simple data transfer from the other worksheets to the target worksheet.

Follow the code, I hope I helped.

Sub transferenciaDeDados()
    transfere_dados
End Sub

Private Function transfere_dados()
    Application.ScreenUpdating = False
    Dim arquivos() As Variant
    Dim caminho As String
    Dim pastaDeTrabalho As String
    Dim pastaDeTrabalhoAtiva As String
    Dim linhaDeInicio As long
    caminho = ActiveWorkbook.Path
    arquivos = listfiles(caminho)
    pastaDeTrabalhoAtiva = ActiveWorkbook.Name
    linhaDeInicio = 1
    'verificação de arquivos
    For Each arquivo In arquivos
        'executa somente se para extenção .xlsx
        If InStr(1, arquivo, ".xlsx") <> 0 And _
            InStr(1, arquivo, "~$") = 0 Then
            pastaDeTrabalho = caminho & "\" & arquivo
            'abre pasta de trabalho
            Workbooks.Open (pastaDeTrabalho)

            'Sua lógica aqui
            'copia valores da célula A1 da primeira planilha da pasta de trabalho aberta
            'em sequência na coluna A da primeira planilha da psta de trabalho de destino, ativa.

            Workbooks(pastaDeTrabalhoAtiva).Sheets(1).Range("A" & linhaDeInicio).Value = _
                Workbooks(arquivo).Sheets(1).Range("A1").Value

            'fecha pasta de trabalho
            Workbooks(arquivo).Close
            linhaDeInicio = linhaDeInicio + 1
        End If
        pastaDeTrabalho = ""
    Next
    pastaDeTrabalhoAtiva = ""
    linhaDeInicio = 0
End Function

Function listfiles(ByVal sPath As String)

    Dim vaArray     As Variant
    Dim i           As long
    Dim oFile       As Object
    Dim oFSO        As Object
    Dim oFolder     As Object
    Dim oFiles      As Object

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sPath)
    Set oFiles = oFolder.Files

    If oFiles.Count = 0 Then Exit Function

    ReDim vaArray(1 To oFiles.Count)
    i = 1
    For Each oFile In oFiles
        vaArray(i) = oFile.Name
        i = i + 1
    Next

    listfiles = vaArray

End Function