Macro para copiar fila completa basado en información de columna especifica

Hice una macro que hasta donde entiendo hace lo que necesitas. Si te fijas, tu pregunta es bastante corta, por ejemplo, no dices en que hoja quieres pegar los datos, tampoco dices que contienen las otras hojas a parte de la columna D o E.

Así que, para que mi macro funcione, deben cumplirse varias reglas (por ahora, hasta que des mas detalles):

1- Que la hoja donde se van a pegar los datos sea la primera hoja (index 1) ya que mi código va a recorrer todas las hojas del libro empezando por la 2da (osea la 1 no se toma en cuenta en el bucle porque se supone que es la hoja destino)

2- La columna A de cada hoja debe tener siempre algún dato. Esto se puede cambiar a cualquier otra columna, pero almenos una columna en cada tabla NO debería admitir espacios en blanco.

Este es el código:

Sub RecorrerHojas()
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
End With
Const PROYECTO As String = "PROYECTO"
Const ARROYOTORO As String = "ARROYO TORO"
Dim HojaDestino As Worksheet: Set HojaDestino = Sheets("Sheet1")
Dim shtCount As Integer: shtCount = ThisWorkbook.Sheets.Count
Dim ColCount As Integer, sht As Integer, ProjPos As Integer, uF As Long, nF As Long, dstCol As Integer
Dim rCell As Range, rRng As Range
For sht = 2 To shtCount
    ColCount = Sheets(sht).Cells(1, Sheets(sht).Columns.Count).End(xlToLeft).Column
    If ColCount > 1 Then
        ProjPos = Sheets(sht).Cells(1, 1).EntireRow.Find(What:=PROYECTO, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
        uF = Sheets(sht).Cells(Rows.Count, ProjPos).End(xlUp).Row
        Set rRng = Sheets(sht).Range(Sheets(sht).Cells(2, ProjPos), Sheets(sht).Cells(uF, ProjPos))
        For Each rCell In rRng.Cells
            If rCell.Value = ARROYOTORO Then
                uF = HojaDestino.Range("A" & Rows.Count).End(xlUp).Row + 1
                For dstCol = 1 To ColCount
                    HojaDestino.Cells(uF, dstCol).Value = Sheets(sht).Cells(rCell.Row, dstCol).Value
                Next dstCol
            End If
        Next rCell
        Set rRng = Nothing
    End If
Next sht
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

El codigo es ejecutable desde cualquier hoja, no necesitas estar en la hoja 1 para correrlo. Siempre va a apuntar a la hoja 1 como la hija destino.

No es necesario usar Copy & Paste (yo lo evito lo mas que pueda)

¿Cómo funciona?:

1-Recorre cada hoja desde la 2 hasta la ultima

2-En cada una busca en la fila 1 (en el encabezado) la palabra PROYECTO y define su columna

3-Una vez encontrada la columna, busca la ultima fila con datos en esa columna

4-Define ese rango, y dentro de ese rango busca cada vez que aparece ARROYO TORO

5-Cada vez que lo encuentre, lo manda a la hoja 1, a la próxima fila vacía.

Revisando el código me doy cuenta que, si en alguna hoja el encabezado "PROYECTO" no existe, da error. Este código corrige ese error:

Sub RecorrerHojas()
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
End With
Const PROYECTO As String = "PROYECTO"
Dim ProjRng As Range
Const ARROYOTORO As String = "ARROYO TORO"
Dim HojaDestino As Worksheet: Set HojaDestino = Sheets("Sheet1")
Dim shtCount As Integer: shtCount = ThisWorkbook.Sheets.Count
Dim ColCount As Integer, sht As Integer, ProjPos As Integer, uF As Long, dstCol As Integer
Dim rCell As Range, rRng As Range
For sht = 2 To shtCount
    ColCount = Sheets(sht).Cells(1, Sheets(sht).Columns.Count).End(xlToLeft).Column
    If ColCount > 1 Then
        Set ProjRng = Sheets(sht).Cells(1, 1).EntireRow.Find(What:=PROYECTO, SearchOrder:=xlByColumns)
        If Not ProjRng Is Nothing Then
        ProjPos = ProjRng.Column
            uF = Sheets(sht).Cells(Rows.Count, ProjPos).End(xlUp).Row
            Set rRng = Sheets(sht).Range(Sheets(sht).Cells(2, ProjPos), Sheets(sht).Cells(uF, ProjPos))
            For Each rCell In rRng.Cells
                If rCell.Value = ARROYOTORO Then
                    uF = HojaDestino.Range("A" & Rows.Count).End(xlUp).Row + 1
                    For dstCol = 1 To ColCount
                        HojaDestino.Cells(uF, dstCol).Value = Sheets(sht).Cells(rCell.Row, dstCol).Value
                    Next dstCol
                End If
            Next rCell
        Set rRng = Nothing
        End If
    End If
Next sht
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Best

Nada, me da error

Si quieres dame tu correo para mandarte el archivo para que lo veas

¿Has ajustado los rangos? El código es general, tu debes adaptarlo a tu libro.

Va a ser mejor si lo subes a Google Drive y lo compartes, así los otros expertos también pueden ver el libro y colaborar.

https://drive.google.com/drive/folders/1bnBKGVjanpW6EKNJIbz1GgtRnKMuQaJh?usp=sharing 

¿A cuál hoja se tienen que pasar los datos de ARROYO TORO?

A una nueva que se genere, te explico, lo que deseo es de ese archivo, que tiene como 100 hojas, sacar las filas que en la columna proyecto diga arroyo toro, el ejemplo tiene pocas hojas pero en realidad son como 100

No hay consistencia en la estructura de las hojas, además de que la columna PROYECTO varia, también la fila del encabezado varia. Con el ejemplo que me mandaste he logrado hacer lo que necesitas, pero si en el libro real siguen variando más cosas, esto se convertirá en un espagueti.

Mira lo que obtiene la macro:

¿Es así como lo quieres?

Ese es el problema que no hay una uniformidad, consistencia. Si de esa manera esta bien así en tabla, ponme esa macro por favor en el archivo que subí a la red o cópiala para correrla aquí en el archivo mio a ver que pasa

Son dos macros, pero solo debes ejecutar la primera la que se llama RecorrerHojas. Pega todo esto en el modulo:

Sub RecorrerHojas()
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
End With
Call CrearHojaDestino
Const FECHA As String = "FECHA"
Dim FechaRng As Range
Const PROYECTO As String = "PROYECTO"
Dim ProjRng As Range
Const ARROYOTORO As String = "ARROYO TORO"
Dim HojaDestino As Worksheet: Set HojaDestino = Sheets("HojaDestino")
HojaDestino.Cells.ClearContents
Dim shtCount As Integer: shtCount = ThisWorkbook.Sheets.Count
Dim ColCount As Integer, sht As Integer, ProjPos As Integer, uF As Long, dstCol As Integer, FechaPos As Integer
Dim rCell As Range, rRng As Range
For sht = 2 To shtCount
Set FechaRng = Sheets(sht).Range("A:A").Find(What:=FECHA, SearchOrder:=xlByRows)
If Not FechaRng Is Nothing Then
    FechaPos = FechaRng.Row
    ColCount = Sheets(sht).Cells(FechaPos, Sheets(sht).Columns.Count).End(xlToLeft).Column
    Set ProjRng = Sheets(sht).Cells(FechaPos, 1).EntireRow.Find(What:=PROYECTO, SearchOrder:=xlByColumns)
    If Not ProjRng Is Nothing Then
    ProjPos = ProjRng.Column
        uF = Sheets(sht).Cells(Rows.Count, ProjPos).End(xlUp).Row
        Set rRng = Sheets(sht).Range(Sheets(sht).Cells(FechaPos, ProjPos), Sheets(sht).Cells(uF, ProjPos))
        For Each rCell In rRng.Cells
            If rCell.Value = ARROYOTORO Then
                uF = HojaDestino.Range("A" & Rows.Count).End(xlUp).Row + 1
                For dstCol = 1 To ColCount
                    HojaDestino.Cells(uF, dstCol).Value = Sheets(sht).Cells(rCell.Row, dstCol).Value
                Next dstCol
            End If
        Next rCell
    Set rRng = Nothing
    End If
End If
Next sht
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Sub CrearHojaDestino()
    Dim newSheetName As String
    Dim checkSheetName As String
    newSheetName = "HojaDestino"
    On Error Resume Next
    checkSheetName = Worksheets(newSheetName).Name
    If checkSheetName = "" Then
        Worksheets.Add.Name = newSheetName
    End If
End Sub

Best

En la segunda macro, donde dice:

If checkSheetName = "" Then
    Worksheets.Add.Name = newSheetName
End If

agrega esta linea:

ActiveSheet.Move Before:=ActiveWorkbook.Sheets(1)

de manera que quede así:

If checkSheetName = "" Then
    Worksheets.Add.Name = newSheetName
    ActiveSheet.Move Before:=ActiveWorkbook.Sheets(1)
End If

Para que la hoja se ponga de primera, ya que dices que son como 100 hojas, para que no te vuelvas loco buscandola

¡Gracias! 

Muy bien le hice unos ajustes y esta perfecta

Esta macro recorre todas las hojas descartando la hoja5, busca en estas la palabra proyecto e identifica la columna donde se encuentra por ejemplo si esta en la columna E entonces E sera igual a 5, si esta en DE, DE sera igual a 4, luego aplicando un filtrado usando el valor de la columna y la palabra Arroyo toro filtra los valores que va a copiar y los envía a la hoja5, ojo para eficientizar la macro el proceso para ti sera invisible, cuando la macro acabe ve a la hoja5

Sub filtrarycopiar()
For Each HOJA In Worksheets
    NOMBRE = UCase(HOJA.Name) = "HOJA5"
    If NOMBRE Then
    Else
        Set DATOS = Sheets(HOJA.Name).Range("a1").CurrentRegion
        col = DATOS.Columns.Count
        columna = WorksheetFunction.Match("PROYECTO", DATOS.Rows(1), 0)
        DATOS.AutoFilter columna, "ARROYO TORO"
        DATOS.Offset(1).Resize(DATOS.Rows.Count - 1).Copy
        FILAS = Sheets("HOJA5").Range("A1").CurrentRegion.Rows.Count
        If FILAS = 1 Then Sheets("HOJA5").Range("A2").PasteSpecial
        If FILAS > 1 Then Sheets("HOJA5").Range("A2").Rows(FILAS).PasteSpecial
        DATOS.AutoFilter
    End If
Next HOJA
shhets("hoja5").select
Set DATOS = Nothing
End Sub

Hola,

Intente correrla pero no me funciona.

Da error en : columna = WorksheetFunction.Match("PROYECTO", DATOS.Rows(1), 0)

Sube una pantalla con tu estructura de datos

Ahi te mando fotos del error que da y de la estructura de la macro

Las Hojas de las que quiero extraer la información son como esta

Si ya vi el problema tienes la referencia en la A12 mientras la macro trabaja sobre la referencia A1, prueba con esta macro, hace lo mismo que la otra solo que ya esta adaptada a tus datos, el resultado es este, en la hoja 5 cin importar en que columna este colocada la palabra proyecto la macro la buscara y sobre esa columna en especifico hara un filtrado y copiado de datos hacia la hoja 5

Sub FILTRARYCOPIAR()
For Each HOJA In Worksheets
NOMBRE = HOJA.Name
If UCase(NOMBRE) <> "HOJA5" Then
FILAS = Sheets(NOMBRE).Range("A" & Rows.Count).End(xlUp).Row
Set DATOS = Sheets(NOMBRE).Range("A12").Resize(FILAS, 24)
With DATOS
    INDICE = WorksheetFunction.Match("PROYECTO", .Rows(1), 0)
    .AutoFilter INDICE, "ARROYO TORO"
    .Offset(1).Copy
    FILAS = Sheets("HOJA5").Range("A1").CurrentRegion.Rows.Count
    If FILAS = 1 Then Sheets("HOJA5").Range("A1").PasteSpecial
    If FILAS > 1 Then Sheets("HOJA5").Range("A1").Rows(FILAS + 1).PasteSpecial
    DATOS.AutoFilter
End With
End If
Next HOJA
Set DATOS = Nothing
End Sub

Nada no se si es mi tipo de archivo, comentaba que me des tu correo para mandártelo el archivo para que lo veas