Generar informe por mes y año con macro

Para Dante Amor

Buen día:

Tengo una macro con la que genero un informe a partir de una base de datos contenida en el archivo que contiene las macros, tengo dificultades cuando el numero de filas con datos supera 3600, creo que es por el tipo de variable que utilizo, pero no he logrado dar con el error, este es el código que utilizo para generar el informe.

De antemano muchas gracias por su constante apoyo.

PD: Le envié al correo el archivo.

'Informe entradas por mes
Private Sub ComboBox1_Enter()
Application.ScreenUpdating = False
Dim i As Double
Dim final As Double
Dim tareas As String
'Muestra el numero del mes
For i = 2 To 30
If Hoja1.Cells(i, 27) = "" Then 'Columna AA hoja Formulario
final = i - 1
Exit For
End If
Next
'Muestra el numero del mes
  For i = 2 To final
  tareas = Hoja1.Cells(i, 27)
  ComboBox1.AddItem (tareas)
  Next
End Sub
Private Sub ComboBox2_Enter()
Application.ScreenUpdating = False
Dim i As Double
Dim final As Double
Dim tareas As String
'Muestra el AÑO
For i = 2 To 30
If Hoja1.Cells(i, 30) = "" Then 'Columna AD hoja Formulario
final = i - 1
Exit For
End If
Next
'Muestra el numero del año
  For i = 2 To final
  tareas = Hoja1.Cells(i, 30)
  ComboBox2.AddItem (tareas)
  Next
End Sub
Private Sub ComboBox1_Click()
Dim i As Integer
Dim final As Integer
'Muestra la descripcion del mes
For i = 2 To 30
If Hoja1.Cells(i, 27) = "" Then 'Columna AA hoja Formulario
final = i - 1
Exit For
End If
Next
'Muestra la descripcion del mes
For i = 2 To final
If CStr(ComboBox1) = CStr(Hoja1.Cells(i, 27)) Then 'Columna AA hoja Formulario
'Muestra la descripcion del mes
TextBox1 = Hoja1.Cells(i, 28)
Exit For
End If
Next
End Sub
Private Sub CommandButton1_Click()
Dim nuevo As Object
Dim i As Integer
Dim L As Integer
Dim j As Integer
Dim VALOR As String
Dim CONTAR As Double
Dim CONTAR1 As Double
Dim libro1 As String
'Extraer el mes de la hoja entradas
ActiveWorkbook.Unprotect "1717171"
Hoja2.Visible = xlSheetVisible 'Hoja Entradas
Sheets("ENTRADAS").Select
libro1 = ActiveWorkbook.Name
Dim mes As String
ult = Hoja2.Range("A" & Rows.Count).End(xlUp).Row
'Extraer el mes y año de la hoja entradas
For y = 2 To ult
    mes = Month(Cells(y, 5)) '5 Indica la columna donde esta la fecha
Hoja2.Unprotect Password = "1717171" 'Hoja entradas
Cells(y, 11) = mes '11 indica la columna donde colocara el No. Del mes
Cells(y, 12) = Year(Cells(y, 5)) 'guarda el año en col 12
Next
Set nuevo = Workbooks.Add
nuevo.Activate
ORIGEN = ActiveWorkbook.Name
For i = 1 To 30000
'ENTRADAS
If Hoja2.Cells(i, 9) = "" Then 'Columna I Hoja Entradas ultima con datos
final = i - 1
Exit For
End If
Next
VALOR = Informe_EA_Mes.ComboBox1
' ENTRADAS
CONTAR = 10 '11
' ASIGNAR VALORES PARA EL INFORME
Application.Workbooks(ORIGEN).Worksheets(1).Cells(1, 1) = "INFORME ENTRADAS POR MES"
Application.Workbooks(ORIGEN).Worksheets(1).Cells(3, 2) = VALOR '3 indica No. De Fila y 2 No. Columna
For L = 1 To 30000
If Hoja1.Cells(L, 27) = VALOR Then
Application.Workbooks(ORIGEN).Worksheets(1).Cells(4, 2) = Hoja1.Cells(L, 28) 'Descricpion del mes
Exit For
End If
Next
For j = 1 To final   'la varible guardó última fila de hoja Entradas
If Hoja2.Cells(j, 11) = VALOR And Hoja2.Cells(j, 12) = Val(ComboBox2) Then
CONTAR = CONTAR + 1
'Funciona entradas
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 2) = Hoja2.Cells(j, 6) 'Numero Fra
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 3) = Hoja2.Cells(j, 1) 'Codigo Item
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 4) = Hoja2.Cells(j, 2) 'Descricpion Item
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 5) = Hoja2.Cells(j, 5) 'Fecha Entrada
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 6) = Hoja2.Cells(j, 3) 'Cantidad entrada
Application.Workbooks(ORIGEN).Worksheets(1).Cells(CONTAR, 7) = Hoja2.Cells(j, 8) 'Valor
End If
Next

1 respuesta

Respuesta
2

Te cambio la macro, revisa el resultado

Private Sub CommandButton1_Click()
'Act.Por.Dante Amor
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("ENTRADAS")
    h1.Unprotect Password = "1717171"
    '
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    If h1.AutoFilterMode Then h1.AutoFilterMode = False
    dia = Day(DateSerial(Year(Val(ComboBox2)), Val(ComboBox1) + 1, 1) - 1)
    fecha = Val(ComboBox1) & "/" & dia & "/" & Val(ComboBox2)
    h1.Range("A1:J" & u).AutoFilter Field:=5, Operator:=xlFilterValues, Criteria2:=Array(1, fecha)
    Set l2 = Workbooks.Add
    Set h2 = l2.Sheets(1)
    j = 2
    cols = Array(6, 1, 2, 5, 3, 8)
    For i = LBound(cols) To UBound(cols)
        h1.Range(h1.Cells(2, cols(i)), h1.Cells(u, cols(i))).Copy h2.Cells(11, j)
        j = j + 1
    Next
    If h1.AutoFilterMode Then h1.AutoFilterMode = False
    h2.Cells(1, 1) = "INFORME ENTRADAS POR MES"
    h2.Cells(3, 2) = ComboBox1
    Call Formato(l2, h2)
    Application.ScreenUpdating = False
    h1.Protect Password = "1717171"
    'Cerrar los UF
    Unload Me
    Unload Informes
    Unload Menu_Principal
End Sub
'
Sub Formato(l2, h2)
    l2.Activate
    h2.Select
        Range("A1:G1").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        With Selection.Interior
            .ColorIndex = 11
            .Pattern = xlSolid
        End With
        Selection.Font.ColorIndex = 2
        Selection.Font.Bold = True
        Range("A3").Select
        ActiveCell.FormulaR1C1 = "No DE MES"
        Range("A4").Select
        ActiveCell.FormulaR1C1 = "DESCRIPCION DEL MES"
        Range("B4") = TextBox1
        Range("B4:F4").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        Range("B3:F3").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        Range("B6:F6").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        'Encabezados del informe
        Range("B8").Select
        ActiveCell.FormulaR1C1 = ""
    'Para entradas
        Range("B10").Select
        ActiveCell.FormulaR1C1 = "No.FACTURA"
        Range("C10").Select
        ActiveCell.FormulaR1C1 = "COD.ITEM"
        Range("D10").Select
        ActiveCell.FormulaR1C1 = "DESCRIPCION"
        Range("E10").Select
        ActiveCell.FormulaR1C1 = "F.ENTRADA"
        Range("F10").Select
        ActiveCell.FormulaR1C1 = "C.ENTRADA"
        Range("G10").Select
        ActiveCell.FormulaR1C1 = "VALOR"
        Range("B8:G8").Select
        With Selection
             .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        ActiveCell.FormulaR1C1 = "ENTRADAS PARA EL MES DE" & " " & Range("B4")
        Range("B8:G8").Select
        With Selection.Interior
            .ColorIndex = 3
            .Pattern = xlSolid
        End With
        Selection.Font.ColorIndex = 2
        Selection.Font.Bold = True
        Range("B10:G10").Select
        Selection.Font.Bold = True
        Range("B10:G10").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("A2").Select
        '***********************************
    'Formato de fecha
        Range("E11").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.NumberFormat = "m/d/yyyy"
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Ejecutar macro si en la celda B1 hay datos

Esta es la macro que utilizo siempre, pero tengo la dificultad que a veces me olvido de colocar el numero de curso (Ejp. 1era_1era o 2da_2da ...)en la celda B1, todo este proceso se ejecuta en la hoja Activa "Curso", lo que busco que la macro se...
2 respuestas

¿Qué hay de mal en este macro?

Quiero hacer un macro para hacer un filtro de una base de datos poniendo como condición un periodo de tiempo, teniendo una celda como fecha de inicio y otra celda como fecha de terminación. Te mando imagen de mi libro y código. Muchas gracias Sub...
1 respuesta

Need a good construction contractor for a home renovation project?

Interested in the uk area. Building a home will be a great investment and dream of their life for most of the people. It is really important to choose the best building contractor for this work. Choosing the right, trustworthy professional contractor...
7 respuestas

Saber el último precio de cierre de cada uno de los valores que compone una cartera de acciones y reflejarlos en un textBox.

Estoy construyendo un formulario para que se vuelque los datos de aquellos la situación de una cartera compuesta por acciones. Es un formulario único pero al clikear en un botón comando se abre un formulario continuo. La situación en la que estoy...
1 respuesta

Como puedo borrar registros relacionados desde un formulario

Tengo un formulario en donde tengo varios registros relacionados, deseo borrar cualquiera de esos registros pero me dice que no puedo borrar registros relacionados, quisiera saber si hay alguna opción con la que pueda borrar.
2 respuestas

Dividir un valor en excel y que el resultado sea igual al de una calculadora manual

Sres. T.E La Consulta es la siguiente: Como dividir 4.888,00 / 30 y que el resultado sea igual tanto en excel como una calculadora manual o la calculado de win xp. Ejemplos: En excel 2003 si divido 4.888,00 / 30 = 162,93 En una Calculadora 4.888,00 /...
2 respuestas

Poner contraseña a una BD de access.

A ver si podéis ayudarme en la siguiente cuestión. Trato de establecer contraseña para la base de datos y no puedo porque aparece un mensaje diciendo que el cifrado de bloques no es compatible con el bloqueo por filas. ¿Cómo puedo arreglar esto?.
2 respuestas

No puedo registrar más de 30k renglones, sale error de desbordamiento (Error 6)

Tengo el siguiente código, que de un formulario pasa los datos a una tabla. El problema es que después de aprox. 35,000 renglones registrados, al querer seguir registrando me aparece el error de desbordamiento (Error 6). Comparto código, si de favor...
3 respuestas

¿Puedo mostrar un subformulario diferente según el valor de un campo para un registro access?

Necesito mostrar un subformulario diferente, según el valor de un campo que llamo "Hecho Extraordinario". Si el hecho es un accidente de transito quiero captar los nombre de los heridos, fallecidos, etc. Si el hecho es un robo de ganado poder captar...
2 respuestas

Error en código para columna de una consulta

Un gusto saludarlos. Quería solicitar su ayuda, porque necesito crear una columna calculada dentro de una consulta access y para eso uso el siguiente código. Saldofinal: IIf(([Nivel]=1 Or [Nivel]=5), ([Sumadesaldoinicial]+[Sumadebe]-[Sumahaber]),...
2 respuestas