Excel - Macro para consolidar en excel

Sub ConsolidarDatos()

'

' ConsolidarDatos Macro

'

' Acceso directo: Ctrl+Mayús+C

'

    Dim colOrigen As Integer

    Dim colReporte As Integer

    Dim fila As Integer

    Dim pos As Integer

    Dim titulo As String

    Dim rangoActual As Range

    Dim cell As Range

    Application.StatusBar = "Consolidación en progreso."

    'Desactivo el refrescado de pantalla

    Application.ScreenUpdating = False

    'Elimino la hoja de reporte si existe

    Application.DisplayAlerts = False

    On Error Resume Next

    ThisWorkbook.Sheets("Reporte").Delete

    On Error GoTo 0

    Application.DisplayAlerts = True

    'Creo la nueva hoja de reporte y la coloco la ultima

    Set hojaNueva = ThisWorkbook.Sheets.Add

    ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)

    ActiveSheet.Name = "Reporte"

    'Esta variable es para saber en que posicion se tiene que empezar a pegar

    'los datos en el reporte

    pos = 2

    'Copio la barra de titulos de la hoja 1 a la hoja de reportes

    Set hoja = ThisWorkbook.Sheets(1)

    hoja.Range("A1:F1").Copy

    hojaNueva.Activate

    hojaNueva.Range("A1:F1").Select

    hojaNueva.Paste

    Application.CutCopyMode = False

    'Ajusto las columnas del reporte para que queden igual que las de la hoja 1

    For Index = 1 To 6

        hojaNueva.Columns(Index).ColumnWidth = hoja.Columns(Index).ColumnWidth

    Next Index

    'Recorro todas las hojas del libro excepto la del reporte

    For Each hoja In ActiveWorkbook.Sheets

        If hoja.Name <> "Reporte" Then

            'Recorro las columnas del reporte para ir buscando cada titulo en las demas hojas

            For colReporte = 1 To 6

                hoja.Activate

                Set rangoActual = Selection

                hoja.Range("A1:F1").Select

                titulo = hojaNueva.Cells(1, colReporte).Text

Buscar:

                'Busco el titulo del reporte en la hoja actual

                Set cell = Selection.Find(What:=titulo, LookIn:=xlFormulas, _

                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _

                MatchCase:=False, SearchFormat:=False)

                'Si no lo encuentra y es porque son los de fechas que son distintos lo corrijo

                'y vuelvo a intentarlo

                If cell Is Nothing Then

                    If titulo = "FECHA A" Then

                        titulo = "FECHA 1"

                        GoTo Buscar

                    ElseIf titulo = "FECHA B" Then

                        titulo = "FECHA 2"

                        GoTo Buscar

                    Else

                        MsgBox "Error en el proceso. No terminó correctamente", vbExclamation Or vbOKOnly, "Error"

                        Exit Sub

                    End If

                Else

                    'Obtengo la columna donde estan los datos para este titulo en la hoja actual

                    colOrigen = cell.Column

                End If

                'Obtengo el rango a copiar de la hoja y lo copio y luego lo pego en el reporte en su columna correcta

                fila = hoja.Cells(hoja.Rows.Count, colOrigen).End(xlUp).Row

                hoja.Range(hoja.Cells(2, colOrigen), hoja.Cells(fila, colOrigen)).Copy

                hojaNueva.Activate

                hojaNueva.Range(hojaNueva.Cells(pos, colReporte), hojaNueva.Cells(pos + fila, colReporte)).Select

                hojaNueva.Paste

                Application.CutCopyMode = False

                hoja.Activate

                hoja.Range(rangoActual.Address).Select

            Next colReporte

            'Incremento la variable para poder seguir pegando los siguientes datos de otra hoja debajo de la anterior

            pos = pos + fila - 1

        End If

    Next hoja

    hojaNueva.Activate

    hojaNueva.Range("A1:F1").Select

    'Busco en el reporte el titulo FECHA A y lo cambio por FECHA AA

    Set cell = Selection.Find(What:="FECHA A", LookIn:=xlFormulas, _

    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _

    MatchCase:=False, SearchFormat:=False)

    cell.Value = "FECHA AA"

    'Busco en el reporte el titulo FECHA B y lo cambio por FECHA BB

    Set cell = Selection.Find(What:="FECHA B", LookIn:=xlFormulas, _

    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _

    MatchCase:=False, SearchFormat:=False)

    cell.Value = "FECHA BB"

    hojaNueva.Range("A1").Select

    Set hoja = Nothing

    Set hojaNueva = Nothing

    Set rangoActual = Nothing

    Set cell = Nothing

    'Vuelvo a activar el refrescado de pantalla

    Application.ScreenUpdating = True

    Application.StatusBar = "Consolidación Terminada."

End Sub