Entrar    Registrar

Copiar em VBA o valor de multiplos arquivos [EXCEL]

Programação Visual Basic

Moderadores: guest2003, 51

  • Autor
    Mensagem

Re: Copiar em VBA o valor de multiplos arquivos [EXCEL]

Mensagempor andre_teprom » 13 Out 2015 19:57

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.
"Por maior que seja o buraco em que você se encontra, relaxe, porque ainda não há terra em cima."
Avatar do usuário
andre_teprom
Dword
 
Mensagens: 4974
Registrado em: 11 Out 2006 18:27
Localização: Portugal

Re: Copiar em VBA o valor de multiplos arquivos [EXCEL]

Mensagempor andre_teprom » 28 Out 2015 14:42

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
Editado pela última vez por andre_teprom em 30 Out 2015 14:15, em um total de 8 vezes.
Razão: Incluído comentários no código, e adicionado uma nova versão vitaminada
"Por maior que seja o buraco em que você se encontra, relaxe, porque ainda não há terra em cima."
Avatar do usuário
andre_teprom
Dword
 
Mensagens: 4974
Registrado em: 11 Out 2006 18:27
Localização: Portugal

Anterior

Voltar para Visual Basic

Quem está online

Usuários navegando neste fórum: Nenhum usuário registrado e 1 visitante