Alimentar un libro con información de otros libros
Necesito alimentar un libro con la información de otros libros.
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro
Sub Concentrar()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
'
Set l1 = ThisWorkbook
Set h2 = l1.Sheets("Hoja2")
Set h3 = l1.Sheets("Hoja3")
h2.Columns("C").Clear
h3.Cells.Clear
j = 1
ruta = h2.[A2]
'
For i = 6 To h2.Range("A" & Rows.Count).End(xlUp).Row
carpeta = h2.Cells(i, "A") & "\"
archivo = h2.Cells(i, "B")
If Dir(ruta & carpeta & archivo) <> "" Then
Set l2 = Workbooks.Open(ruta & carpeta & archivo)
For Each h In l2.Sheets
Select Case UCase(h.Name)
Case "HOJA1", "HOJA2"
Case Else
h3.Cells(j, "A") = carpeta
h3.Cells(j, "B") = archivo
h3.Cells(j, "C") = h.Name
j = j + 1
End Select
Next
l2.Close
Else
h2.Cells(i, "C") = "No existe el archivo"
End If
Next
'
ordenar h3
Set l2 = Workbooks.Add
For i = 1 To h3.Range("A" & Rows.Count).End(xlUp).Row
carpeta = h3.Cells(i, "A")
archivo = h3.Cells(i, "B")
hoja = h3.Cells(i, "C")
Set l3 = Workbooks.Add(ruta & carpeta & archivo)
l3.Sheets(hoja).Copy after:=l2.Sheets(l2.Sheets.Count)
l3.Close False
Next
carpeta = h2.[A4] & "\"
archivo = h2.[B4]
l2.SaveAs ruta & carpeta & archivo
Application.ScreenUpdating = True
MsgBox "Proceso terminado"
End Sub
'
Sub ordenar(h3)
'Por.Dante Amor
u = h3.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To u
espacio = InStr(1, h3.Cells(i, "C"), " ")
h3.Cells(i, "D") = Left(h3.Cells(i, "C"), espacio - 1)
Next
With h3.Sort
.SortFields.Clear: .SortFields.Add Key:=h3.Range("D1:D" & u)
.SetRange h3.Range("A1:D" & u): .Header = xlGuess: .Apply
End With
End Subsal u dos
Te anexo la macro actualizada
Sub Concentrar()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
'
BorrarHojas
Set l1 = ThisWorkbook
Set h2 = l1.Sheets("Hoja2")
Set h3 = l1.Sheets("Hoja3")
h2.Columns("C").Clear
h3.Cells.Clear
j = 1
ruta = h2.[A2]
'
For i = 6 To h2.Range("A" & Rows.Count).End(xlUp).Row
carpeta = h2.Cells(i, "A") & "\"
archivo = h2.Cells(i, "B")
If Dir(ruta & carpeta & archivo) <> "" Then
Set l2 = Workbooks.Open(ruta & carpeta & archivo, UpdateLinks:=0, ReadOnly:=True)
For Each h In l2.Sheets
Select Case UCase(h.Name)
Case UCase("Hoja1"), UCase("Projects"), UCase("Summary Definition"), _
UCase("Gantt"), UCase("Project Pending"), UCase("Plan de Comunicación")
Case Else
h3.Cells(j, "A") = carpeta
h3.Cells(j, "B") = archivo
h3.Cells(j, "C") = h.Name
j = j + 1
End Select
Next
l2.Close
Else
h2.Cells(i, "C") = "No existe el archivo"
End If
Next
'
ordenar h3
For i = 1 To h3.Range("A" & Rows.Count).End(xlUp).Row
carpeta = h3.Cells(i, "A")
archivo = h3.Cells(i, "B")
hoja = h3.Cells(i, "C")
Set l3 = Workbooks.Open(ruta & carpeta & archivo, UpdateLinks:=0, ReadOnly:=True)
l3.Sheets(hoja).Copy after:=l1.Sheets(l1.Sheets.Count)
l3.Close False
Next
carpeta = h2.[A4] & "\"
archivo = h2.[B4]
l1.Save
Application.ScreenUpdating = True
MsgBox "Proceso terminado"
End Sub
'
Sub ordenar(h3)
'Por.Dante Amor
u = h3.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To u
espacio = InStr(1, h3.Cells(i, "C"), " ")
If espacio > 0 Then
h3.Cells(i, "D") = Left(h3.Cells(i, "C"), espacio - 1)
Else
h3.Cells(i, "D") = h3.Cells(i, "C")
End If
Next
With h3.Sort
.SortFields.Clear: .SortFields.Add Key:=h3.Range("D1:D" & u)
.SetRange h3.Range("A1:D" & u): .Header = xlGuess: .Apply
End With
End Sub
'
Sub BorrarHojas()
'Por.Dante Amor
Application.DisplayAlerts = False
For i = Sheets.Count To 7 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
End Sub
