Buscar con varias condiciones para crear reporte con Macros

Tengo un libro con 3 hojas, en una de ellas se tienen las variables, en otra los datos y en la tercera se necesita construir el reporte.

Hay que traer los conceptos de las celdas C, D y E, según parámetros, a la hoja Reporte.

Si motivo es H en la hoja parámetro se crea cabecera desde celda A con: A Concepto, B Haberes y C Importe

Se suman todos los conceptos con el valor del importe de los conceptos de columna H de Base (se suma según conceptos de columna D)

Los conceptos que quedan con importe cero eliminarlos.

Los conceptos que quedan en Reporte deben mantener el orden que se trajo de parámetros.

Se debe crear una linea con el Total de haberes (suma el importe total de haberes)

Si motivo es D en la hoja parámetro se crea cabecera desde celda E con: E Concepto, F Descuentos y G Importe

Se suman todos los conceptos con el valor del importe de los conceptos de columna H de Base (se suma según conceptos de columna D)

Los conceptos que quedan con importe cero eliminarlos.

Los conceptos que quedan en Reporte deben mantener el orden que se trajo de parámetros.

Se debe crear una linea con el Total de descuentos (suma el importe total de descuentos)

Finalmente se crea una linea con el Liquido (Total haberes - Total descuentos)

Todo esto teniendo en cuenta que se debe trabajar con los datos de Sociedad 10 de la hoja Base.

Además se pide 2 botones para trabajar las macros.

Botón que genere reporte si no hay datos en hoja Reporte.

Botón que borre los datos de la hoja para poder generar el reporte.

Se quiere trabajar con macros porque los registros serán muchos y lo mejor es automatizar los reportes.

Variables

Base

Reporte

1 respuesta

Respuesta
1

Te anexo la macro para crear el reporte:

Sub Reporte()
'Por.Dante Amor
    Set h1 = Sheets("Base")
    Set h2 = Sheets("Variables")
    Set h3 = Sheets("Reporte")
    '
    u3 = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
    h3.Range("A2:G" & u3).Clear
    '
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        existe = False
        Set r = h2.Columns("C")
        Set b = r.Find(h1.Cells(i, "D"), lookat:=xlWhole)
        If Not b Is Nothing Then
            ncell = b.Address
            Do
                'detalle
                If h2.Cells(b.Row, "A") = h1.Cells(i, "A") Then
                    existe = True
                    wvar = h2.Cells(b.Row, "E")
                    Exit Do
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> ncell
            '
            If existe Then
                If wvar = "H" Then
                    Set b = h3.Range("A:A").Find(h1.Cells(i, "D"), lookat:=xlWhole)
                    If Not b Is Nothing Then
                        h3.Cells(b.Row, "C") = h3.Cells(b.Row, "C") + h1.Cells(i, "H")
                    Else
                        u = h3.Range("A" & Rows.Count).End(xlUp).Row + 1
                        h3.Cells(u, "A") = h1.Cells(i, "D")
                        h3.Cells(u, "B") = h1.Cells(i, "E")
                        h3.Cells(u, "C") = h1.Cells(i, "H")
                    End If
                    wtoth = wtoth + h1.Cells(i, "H")
                Else
                    Set b = h3.Range("E:E").Find(h1.Cells(i, "D"), lookat:=xlWhole)
                    If Not b Is Nothing Then
                        h3.Cells(b.Row, "G") = h3.Cells(b.Row, "G") + h1.Cells(i, "H")
                    Else
                        u = h3.Range("E" & Rows.Count).End(xlUp).Row + 1
                        h3.Cells(u, "E") = h1.Cells(i, "D")
                        h3.Cells(u, "F") = h1.Cells(i, "E")
                        h3.Cells(u, "G") = h1.Cells(i, "H")
                    End If
                    wtotd = wtotd + h1.Cells(i, "H")
                End If
            End If
        End If
    Next
    '
    '
    h3.Select
    MsgBox "Reporte terminado", vbInformation
End Sub

Para la parte de ordenar y poner los totales, podrías crear una nueva pregunta, debes solicitar en una pregunta nueva por cada petición.

Saludos. Dante Amor

Recuerda valorar la respuesta.

Te anexo la macro actualizada:

Sub Reporte()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("Base")
    Set h2 = Sheets("Variables")
    Set h3 = Sheets("Reporte")
    '
    u3 = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
    h3.Range("A2:G" & u3).ClearContents
    '
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        existe = False
        Set r = h2.Columns("C")
        Set b = r.Find(h1.Cells(i, "D"), lookat:=xlWhole)
        If Not b Is Nothing Then
            ncell = b.Address
            Do
                'detalle
                If h2.Cells(b.Row, "A") = h1.Cells(i, "A") Then
                    existe = True
                    wvar = h2.Cells(b.Row, "E")
                    Exit Do
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> ncell
            '
            If existe Then
                If wvar = "H" Then
                    Set b = h3.Range("A:A").Find(h1.Cells(i, "D"), lookat:=xlWhole)
                    If Not b Is Nothing Then
                        h3.Cells(b.Row, "C") = h3.Cells(b.Row, "C") + h1.Cells(i, "H")
                    Else
                        u = h3.Range("A" & Rows.Count).End(xlUp).Row + 1
                        h3.Cells(u, "A") = h1.Cells(i, "D")
                        h3.Cells(u, "B") = h1.Cells(i, "E")
                        h3.Cells(u, "C") = h1.Cells(i, "H")
                    End If
                    wtoth = wtoth + h1.Cells(i, "H")
                ElseIf wvar = "D" Then
                    Set b = h3.Range("E:E").Find(h1.Cells(i, "D"), lookat:=xlWhole)
                    If Not b Is Nothing Then
                        h3.Cells(b.Row, "G") = h3.Cells(b.Row, "G") + (h1.Cells(i, "H") * -1)
                    Else
                        u = h3.Range("E" & Rows.Count).End(xlUp).Row + 1
                        h3.Cells(u, "E") = h1.Cells(i, "D")
                        h3.Cells(u, "F") = h1.Cells(i, "E")
                        h3.Cells(u, "G") = h1.Cells(i, "H") * -1
                    End If
                    wtotd = wtotd + h1.Cells(i, "H")
                End If
            End If
        End If
    Next
    '
    u = h3.Range("A" & Rows.Count).End(xlUp).Row
    With h3.Sort
     .SortFields.Clear: .SortFields.Add Key:=h3.Range("A2:A" & u)
     .SetRange h3.Range("A1:C" & u): .Header = xlYes: .Apply
    End With
    '
    u = h3.Range("E" & Rows.Count).End(xlUp).Row
    With h3.Sort
     .SortFields.Clear: .SortFields.Add Key:=h3.Range("E2:E" & u)
     .SetRange h3.Range("E1:G" & u): .Header = xlYes: .Apply
    End With
    '
    '
    Application.ScreenUpdating = True
    h3.Select
    MsgBox "Reporte terminado", vbInformation
End Sub

Saludos.Dante Amor

Recuerda valorar la respuesta.

Excelente

Es lo que necesitaba

Recuerda valorar la respuesta, al final de la respuesta aparecen dos botones.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas