Hola Amigos del Foro  

 

Necesito su ayuda he conseguido una Macro que se acopla a mis necesidades tengo un archivo con mas de 60 hojas todas tienen el mismo formato y necesito hacer una búsqueda para que me traiga el resultado de cada hoja hasta ahí todo iba bien es mas me trae el resultado si este esta en formato  "Texto".

 

Pero la mayoría de los filtros que necesito traer  estan en formato  Números Ejem: " Referencia 917" esos datos no me los trae y NO tengo idea por que.

Adjunto archivo 

 

Cita
Cita
Sub Buscador()
    Dim sNoBuscar As String
    Dim wHoja As Worksheet
    Dim sCodEBS As String
    Dim nSubCoincide As Double
    Dim nTotCoincide As Double
    Dim wHojaResumen As Worksheet
    Dim firstAddress
    Dim c As Range
    Dim nFilaCopia As Double
    
    
    Dim sDescripcion As String
    Dim sReferencia As String
    Dim rRangoBusca As Range
    Dim sBusca As String
    Dim bValido As Boolean


    Set wHojaResumen = Worksheets("Busqueda")
    wHojaResumen.Select
    nFilaCopia = wHojaResumen.Range("B" & Rows.Count).End(xlUp).Row
    wHojaResumen.Range("A9:AE" & nFilaCopia + 9).ClearContents
    wHojaResumen.Range("A9:AE" & nFilaCopia + 9).Borders.LineStyle = xlNone
    
    sNoBuscar = "Busqueda;"
        
    sDescripcion = Trim(wHojaResumen.Range("B2").Value)
    sReferencia = Trim(wHojaResumen.Range("B3").Value)
    nFilaCopia = 9
    
    For Each wHoja In ActiveWorkbook.Sheets
        nSubCoincide = 0
        If InStr(1, sNoBuscar, wHoja.Name) = 0 Then
            If sDescripcion <> "" Then
                nSubCoincide = Application.WorksheetFunction.CountIf(wHoja.Range("C:C"), "*" & Trim(sDescripcion) & "*")
                Set rRangoBusca = wHoja.Range("C:C")
                sBusca = sDescripcion
            ElseIf sReferencia <> "" Then
                nSubCoincide = Application.WorksheetFunction.CountIf(wHoja.Range("D:D"), "*" & Trim(sReferencia) & "*")
                Set rRangoBusca = wHoja.Range("D:D")
                sBusca = sReferencia
            ElseIf sEditorial <> "" Then
            
            End If
            
            If nSubCoincide > 0 Then
                With rRangoBusca
                    Set c = .Find("*" & sBusca & "*", LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        Do
                            bValido = True
                            If sDescripcion <> "" Then
                                If InStr(1, Trim(wHoja.Range("C" & c.Row)), Trim(sDescripcion)) = 0 Then
                                    bValido = False
                                End If
                            End If
                            If sReferencia <> "" And bValido = True Then
                                If InStr(1, Trim(wHoja.Range("D" & c.Row)), Trim(sReferencia)) = 0 Then
                                    bValido = False
                                End If
                            
                            End If
                            If bValido = True Then
                                wHojaResumen.Range("A" & nFilaCopia).Value = "'" & wHoja.Range("A" & c.Row)
                                wHojaResumen.Range("B" & nFilaCopia).Value = wHoja.Range("B" & c.Row)
                                wHojaResumen.Range("C" & nFilaCopia).Value = wHoja.Range("C" & c.Row)
                                wHojaResumen.Range("D" & nFilaCopia).Value = wHoja.Range("D" & c.Row)
                                wHojaResumen.Range("E" & nFilaCopia).Value = wHoja.Range("E" & c.Row)
                                wHojaResumen.Range("F" & nFilaCopia).Value = wHoja.Range("F" & c.Row)
                                wHojaResumen.Range("G" & nFilaCopia).Value = wHoja.Range("G" & c.Row)
                                wHojaResumen.Range("H" & nFilaCopia).Value = wHoja.Range("H" & c.Row)
                                wHojaResumen.Range("I" & nFilaCopia).Value = wHoja.Range("I" & c.Row)
                                wHojaResumen.Range("J" & nFilaCopia).Value = wHoja.Range("J" & c.Row)
                                wHojaResumen.Range("K" & nFilaCopia).Value = wHoja.Range("K" & c.Row)
                                nFilaCopia = nFilaCopia + 1
                            End If
    
                            Set c = .FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> firstAddress
                    End If
                End With
            End If
        End If
    Next
    
    nFilaCopia = wHojaResumen.Range("B" & Rows.Count).End(xlUp).Row
    If nFilaCopia > 8 Then
        wHojaResumen.Range("A9:AE" & nFilaCopia).Borders.LineStyle = xlContinuous
    End If
End Sub

 

 

 

Filtro Varias Hojas y Consolida informacion en 1 Sola.xlsm

Me falto informar que si quiero consultar en Minúsculas y esta en Mayúsculas tampoco me trae la información

 

Agradezco su ayuda 

¡Hola, @Favic!

Dejo una opción en el adjunto.  Cambié la posición de los criterios en A2:B3 para que coincidiera con un filtro avanzado.  De esta forma, el código quedará mucho más pequeño, además que el rendimiento mejorará bastante.

Nota:  

Normalmente, el filtro avanzado busca no de forma exacta, sino por lo que comienza de lo que pongas en sus criterios.

Ejemplo:  Si colocas en A3 la letra a, el filtro avanzado trae como resultado todo lo que comienza por la letra a.  Así que, si quieres que traiga lo que diga exactamente a, puedes colocar en la celda A3 '=a (importante el apóstrofo).  Verás =a en la celda.

¡Bendiciones!

Filtro Varias Hojas y Consolida informacion en 1 Sola.xlsm

Hola  @johnmpl

Muchas gracias estuvo muy bueno tu apunte pero como recortaste el código no tengo forma de enviar los datos hasta la columna "AE"   es que necesito que traiga todos los valores yo se que en este momento no tienen datos pero en el archivo original todos están llenos.

 

Me podrías ayuda para llevar a cabo este resultado

¡Hola de nuevo, @Favic!

En ese caso, modifica el código por el siguiente:

Sub Buscador()
    Dim Hj As Worksheet, uf&, uf2&
    
    Application.ScreenUpdating = False
    
    uf = Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("A9:AE" & uf).Delete xlUp
    For Each Hj In Worksheets
        If Hj.Name <> "Busqueda" Then
            uf = Range("A" & Rows.Count).End(xlUp).Row + 1
            Range("A8:AE8").Copy Range("A" & uf)
            uf2 = Hj.Range("A" & Rows.Count).End(xlUp).Row
            Hj.Range("A6:H" & uf2).AdvancedFilter xlFilterCopy, Range("A2:B3"), Range("A" & uf, "H" & uf)
            Hj.Range("K6:AE" & uf2).AdvancedFilter xlFilterCopy, Range("A2:B3"), Range("K" & uf, "AE" & uf)
            Range("A" & uf, "AE" & uf).Delete xlUp
        End If
    Next Hj
    
    Application.ScreenUpdating = True
End Sub

Esta modificación es debida a que el filtro avanzado no admite títulos en blanco, y porque tienes datos pegados inmediatamente arriba de los títulos en cada hoja.  ¡Bendiciones!

 

Hola @johnmpl 

Coloco el nuevo código y no me trae los demás datos de las columnas siguientes.

 

Subo el archivo para que veas que me sigue trayendo lo de la primera macro

 

Gracias por su colaboracion

 

 

Filtro Varias Hojas y Consolida informacion en 1 Sola 2.0.xlsm

 

@johnmpl

Subo nuevamente con la corrección del código

 

y con datos en las columnas subsiguientes para probar la modificación

Filtro Varias Hojas y Consolida informacion en 1 Sola 2.0.xlsm

¡Hola, @Favic!

Tenías razón.  Con esta nueva modificación, no debe haber nada en las columnas I, J.  Ahí coloco, en la fila 8 - hoja búsqueda - y en la fila 6 - cada hoja - auxiliares que luego borro, para hacer el tratamiento de los datos como una sola unidad, y que los tome el filtro avanzado.  El nuevo código, es el siguiente:

Sub Buscador()
    Dim Hj As Worksheet, uf&, uf2&
    
    Application.ScreenUpdating = False
    uf = Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("I8:J8") = Array("e1", "e2")
    Range("A9:AE" & uf).Delete xlUp
    For Each Hj In Worksheets
        If Hj.Name <> "Busqueda" Then
            uf = Range("A" & Rows.Count).End(xlUp).Row + 1
            Hj.Range("I6:J6") = Array("e1", "e2")
            Range("A8:AE8").Copy Range("A" & uf)
            uf2 = Hj.Range("A" & Rows.Count).End(xlUp).Row
            Hj.Range("A6:AE" & uf2).AdvancedFilter xlFilterCopy, Range("A2:B3"), Range("A" & uf, "AE" & uf)
            Range("A" & uf, "AE" & uf).Delete xlUp
            Hj.Range("I6:J6").Clear
        End If
    Next Hj
    Range("I8:J8").Clear
    Application.ScreenUpdating = True
End Sub

¡Bendiciones!

MUCHAS GRACIAS @johnmpl Doy por solucionado este tema 

Eres muy gentil.

Hola @johnmpl Otra vez

 

Pues que te digo estaba super contento por que la tabla estaba super y no generaba error ni nada.

Pero cuando fui a colocarla al archivo original por el tipo de formato me dice que no se puede adjunte el tipo de formato al archivo para que se vea.

Estoy pasando del archivo original a la macro Moviendo todas la hojas de una vez.

No se si se puede hacer algo o que me aconsejas 

.https://drive.google.com/file/d/0B3y8qj08UdAUQV9CZkZpdFEtSGs/view?usp=sharing

¡Hola de nuevo, @Favic!

En los títulos... ¡No pueden haber celdas combinadas ni celdas en blanco!  Es de ahí la importancia de lo que te escribí

Hace 2 horas, johnmpl dijo:

Con esta nueva modificación, no debe haber nada en las columnas I, J

Como en tu estructura inicial no tenías nada en estas columnas; rellené de forma manual con las palabras e1 y e2 respectivamente.  Por eso te repregunto:  ¿Tienes datos originalmente ahí?  Si no... ¿por qué la necesidad de combinar?

Si hay cambios en la estructura, sube el archivo con las modificaciones.

Otra cosa que debes tener en cuenta es que los títulos de las columnas deben ser iguales en todas las hojas, para que el filtro avanzado las reconozca.

Revisa el adjunto, por favor.  ¡Bendiciones!

Filtro Varias Hojas y Consolida informacion en 1 Sola 3.0.xlsm

Tema abandonado.