Macro para copiar datos de distintos libros en uno solo
Para Dante Amor: hola Dante, necesito si me puedes ayudar, ya tengo una macro que me has ayudado que sacar filas de varios libros de excel y los pega en una hoja como resumen. Ahora quisiera que solo me traiga la fecha que yo introduzco en un inpux box!. Y no todos los datos, la fecha en los archivos que busco está en la columna "B".
te paso macro existente .
'
Sub copia_hojas3()
'------------------
'by niko
'
'------------------
Application.DisplayStatusBar = True
Application.StatusBar = "Procesando datos..."
Dim ws As Worksheet, iFile$, iRow&, mFolder$
Set ws = ActiveSheet
ws.Range(ws.[a1], ws.[a1].SpecialCells(11)).Offset(1).Delete xlShiftUp
iRow = 2
Folders = Array(ThisWorkbook.path & "\AGLOMERADOS", ThisWorkbook.path & "\FOLIO", ThisWorkbook.path & "\IMPREGNACION", ThisWorkbook.path & "\LAM1", _
ThisWorkbook.path & "\LAM2", ThisWorkbook.path & "\LAM3", ThisWorkbook.path & "\LIJADORA AGLO", ThisWorkbook.path & "\LIJADORA MDF", _
ThisWorkbook.path & "\MDF1", ThisWorkbook.path & "\MDF2", ThisWorkbook.path & "\MOLDURERA1", _
ThisWorkbook.path & "\MOLDURERA2", ThisWorkbook.path & "\MOLDURERA3")
For i = LBound(Folders) To UBound(Folders)
mFolder = Folders(i)
iFile = Dir(mFolder & "\*.xlsm*")
Do Until iFile = ""
Call copiar1(ws, iRow, mFolder, iFile)
iFile = Dir
Loop
Next
'
Application.StatusBar = False
MsgBox "Todo los datos extraídos"
End Sub
Sub copiar1(ws, iRow, mFolder, iFile)
With ws.Cells(iRow, "a").Resize(30, 7)
.Formula = "=if('" & mFolder & "\[" & iFile & "]Histórico'!b2 ="""", """" ,'" & mFolder & "\[" & iFile & "]Histórico'!a2)"
.Value = .Value
iRow = iRow + 30
tope = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
End With
For f = tope To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(f)) = 0 Then Rows(f).EntireRow.Delete
Next
End Sub
1 respuesta
Te anexo la macro con los cambios
Sub copia_hojas3()
'------------------
'by niko
'
'------------------
Application.DisplayStatusBar = True
'
'Act Por Dante Amor
fecha = InputBox("Ingresa la fecha dd/mm/aaaa:", "COPIAR SOLAMENTE ESTA FECHA")
If fecha = "" Or Not IsDate(fecha) Then
MsgBox "Faltó ingresar fecha"
Exit Sub
End If
dfecha = CDate(fecha)
'
Application.StatusBar = "Procesando datos..."
Dim ws As Worksheet, iFile$, iRow&, mFolder$
Set ws = ActiveSheet
ws.Range(ws.[a1], ws.[a1].SpecialCells(11)).Offset(1).Delete xlShiftUp
iRow = 2
Folders = Array(ThisWorkbook.Path & "\AGLOMERADOS", ThisWorkbook.Path & "\FOLIO", ThisWorkbook.Path & "\IMPREGNACION", ThisWorkbook.Path & "\LAM1", _
ThisWorkbook.Path & "\LAM2", ThisWorkbook.Path & "\LAM3", ThisWorkbook.Path & "\LIJADORA AGLO", ThisWorkbook.Path & "\LIJADORA MDF", _
ThisWorkbook.Path & "\MDF1", ThisWorkbook.Path & "\MDF2", ThisWorkbook.Path & "\MOLDURERA1", _
ThisWorkbook.Path & "\MOLDURERA2", ThisWorkbook.Path & "\MOLDURERA3")
For i = LBound(Folders) To UBound(Folders)
mFolder = Folders(i)
iFile = Dir(mFolder & "\*.xlsm*")
Do Until iFile = ""
Call copiar1(ws, iRow, mFolder, iFile, dfecha)
iFile = Dir
Loop
Next
'
Application.StatusBar = False
MsgBox "Todo los datos extraídos"
End Sub
'
Sub copiar1(ws, iRow, mFolder, iFile, dfecha)
With ws.Cells(iRow, "a").Resize(30, 7)
.Formula = "=if('" & mFolder & "\[" & iFile & "]Histórico'!b2 ="""", """" ,'" & mFolder & "\[" & iFile & "]Histórico'!a2)"
.Value = .Value
iRow = iRow + 30
tope = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
End With
For f = tope To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(f)) = 0 Then Rows(f).EntireRow.Delete
If Cells(f, "B") <> dfecha Then Rows(f).EntireRow.Delete
Next
End Sub.[Sal u dos. Dante Amor. No olvides valorar la respuesta.
.[
