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
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 SubPara 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 SubSaludos.Dante Amor
Recuerda valorar la respuesta.
Excelente
Es lo que necesitaba
Recuerda valorar la respuesta, al final de la respuesta aparecen dos botones.
