Filtrar y copiar columnas a otra hoja

[Potter08]

Buenas tarde, me surge la siguiente interrogante, me podrian ayudar con este archivo necesito filtrar la columna ingresos y copiar el filtro a otra hoja pero solo la columna ingresos y la columna producto una debajo de otra, para hacer un resumen de los ingresos por dia, adjunto ejemplo hay que consolidar las tres hojas en una sola, espero que mi explicacion sea entendible, salu2.

Como propuesta espero sea una macro en base a filtros que filtre de ingresos solo los valores diferentes de cero y los copie a la hoja resultado, me podrian ayudar con el codigo como seleccionar la columna filtrada y la columna producto solo las filas visibles nada mas, de ahi en adelante creo que puedo armar el resto del codigo. gracias

Filtrar y Copiar solo 2 columnas.xls

[Potter08]

Bien octube el siguiente codigo en la web y quiero adaptarlo al archivo que adjunte alguien que me ayude please pero que al encontrar la palabra Ingreso me filtre ese rango y me copie eso valores asi como esta en el ejemplo. saludos

Sub CopyDiscontiguousColumns()

Dim wsFrom As Excel.Worksheet

Dim wsTo As Excel.Worksheet

Dim RangeToCopy As Excel.Range

Dim HeaderRange As Excel.Range

Dim HeaderText As String

Dim FirstFoundHeader As Excel.Range

Dim NextFoundHeader As Excel.Range

Dim LastRow As Long


Set wsFrom = ThisWorkbook.Worksheets(1)

Set wsTo = ThisWorkbook.Worksheets(2)

'headers are in row 2

Set HeaderRange = wsFrom.Rows(2)

'This is the text that identifies columns to be copies

HeaderText = "Ingreso"

With wsFrom

    'look for the first instance of "copy" in the header row

    Set FirstFoundHeader = HeaderRange.Find(HeaderText)

    'if "copy" is found, we're off and running

    If Not FirstFoundHeader Is Nothing Then

        LastRow = .Cells(.Rows.Count, FirstFoundHeader.Column).End(xlUp).Row

        Set NextFoundHeader = FirstFoundHeader

        'start to build the range with columns to copy

        Set RangeToCopy = .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column))

        'and then just keep doing the same thing in a loop until we get back to the start

        Do

        Set NextFoundHeader = HeaderRange.FindNext(NextFoundHeader)

            If Not NextFoundHeader Is Nothing Then

                Set RangeToCopy = Union(RangeToCopy, .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column)))

            End If

        Loop While Not NextFoundHeader Is Nothing And NextFoundHeader.Address <> FirstFoundHeader.Address

    End If

End With

RangeToCopy.Copy

Sheet2.Range("A3").PasteSpecial xlValues

End Sub

[/CODE]