Macro copiar información de un Libro a otro y consolidarla

Escribo porque necesito tu ayuda con esta Macro lo que necesito que realice es que copie las 16 hojas de un libro en otro libro, lo que sucede es que algunas veces me funciona común y corriente y otras veces me salen este tipo de errores:

* El encabezado es el mismo que el libro destino

* La variable h fuera del intervalo

* Si abro varios libros de Excel me copia información de otros libros de excel que no debería copiar.

Acá dejo el código te agradezco tu ayuda.

Sub Consolidar()

Dim h As Long

Dim ultima As Integer

Dim Origen As Workbook

Dim HOrigen As Worksheet

Dim Destino As Workbook

Dim HDestino As Worksheet

Dim ruta As String

ruta = ("C:\Users\lina h\Desktop\TRAB\REPORTE_ABOGADOS")

Set Destino = Workbooks(ThisWorkbook.Name)

Set HDestino = Destino.Worksheets("Consolidado")

Call LimpiarTotal

Set Origen = Workbooks.Open(ruta)

For h = 2 To Sheets.Count

  Origen.Activate

  Sheets(h).Activate

  Range("A2").Select

  Range(Selection, Cells(2, 15)).Select

  Range(Selection, Selection.End(xlDown)).Select

  Selection.Copy

  Destino.Activate

  HDestino.Select

  Range("A2").Select

  If h > 2 Then

   ultima = Cells(Rows.Count, 1).End(xlUp).Row

   Cells(ultima, 1).Offset(0, 0).Select

   Range("A" & Selection.Row + 1).Select

   Else

   Range("A2").Select

  End If

  ActiveSheet.Paste

Next

End Sub

Sub LimpiarTotal()

  Sheets(2).Select

  Range("A2").Select

  Range(Selection, Cells(2, 15)).Select

  Range(Selection, Selection.End(xlDown)).Select

  Application.CutCopyMode = False

  Selection.ClearContents

  Range("A2").Select

End Sub

Respuesta

Intenta de esta manera, si te marca error me dices en qué línea y cual es el error.

Sub Consolidar()
Dim h As Long
Dim ultima As Integer
Dim Origen, destino As Workbook
Dim HOrigen, HDestino As Worksheet
Dim ruta As String
ruta = ("C:\Users\lina h\Desktop\TRAB\REPORTE_ABOGADOS")
Set destino = ThisWorkbook
Set HDestino = destino.Worksheets("Consolidado")
Call LimpiarTotal
Set Origen = Workbooks.Open(ruta)
Origen.Activate
For h = 2 To Origen.Sheets.Count
Origen.Sheets(h).Activate
  Range("A2").Select
  Range(Selection, Cells(2, 15)).Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.Copy
  destino.Activate
  HDestino.Select
  Range("A2").Select
  If h > 2 Then
   ultima = Cells(Rows.Count, 1).End(xlUp).Row
   Cells(ultima, 1).Offset(0, 0).Select
   Range("A" & Selection.Row + 1).Select
   Else
   Range("A2").Select
  End If
  ActiveSheet.Paste
Next
End Sub
Sub LimpiarTotal()
  Sheets(2).Select
  Range("A2").Select
  Range(Selection, Cells(2, 15)).Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents
  Range("A2").Select
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas