Macro Excel 2016 para reducir su tamaño

¿Puedes subir una captura de pantalla de tu formulario y de la hoja de tus datos?, ¿Y explícame que hace la macro?, a lo mejor yo puedo ayudarte si me brindas lo que te pedí.

Gracias James

Formulario

Como se observa, tiene 3 optionButton que se refere na 3 hojas. Quiero que busque en la hoja según el option esté true

Las hojas puedes observar que la hoja Productos tien más columnas que las 2 demás y las fechas están en columnas diferentes.

La hoja Productos, 7 columnas y la fecha esta en la E

La hoja Entrada 5 columnas y la fecha esta en columna D

La hoja Salidas, es precisamente igual a la hoja Entrada; 5 columnas y la fecha en la D

El mayor problema es la disparidad de la colocación de la fecha de la hoja Productos y las 2 restantes

Prueba esta macro, dependiendo de cual botón elijas es la hoja que carga en el listbox basándose en la fecha, si la fecha inicial no existe en cuialquiera de las hojas no cargara nada y te enviara un mensaje, tiene menos líneas ya que una sola macro controla la misma acción para los 3 botones y se posiciona en la columna fecha de cualquiera de las tes hojas

Private Sub OptionButton1_Click()
CARGA
End Sub
Private Sub OptionButton2_Click()
CARGA
End Sub
Private Sub OptionButton3_Click()
CARGA
End Sub
Sub CARGA()
FECHA_INICIAL = Format(DTPicker1, "mm/dd/yyyy")
FECHA_FINAL = Format(DTPicker2, "mm/dd/yyyy")
fecha = DTPicker1
If OptionButton1 = True Then
COLUMNA = Range("E1").Column
Set HT = Worksheets("PRODUCTO")
End If
If OptionButton2 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("ENTRADAS")
End If
If OptionButton3 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("SALIDAS")
End If
If FECHA_INICIAL = FECHA_FINAL Or FECHA_INICIAL > FECHA_FINAL Then
    MsgBox ("LAS FECHAS NO PUEDEN SER IGUALES NI LA FECHA INICIAL PUEDE SER MAYOR QUE LA FECHA FINAL"), vbInformation, "AVISO"
Else
    Set DATOS = HT.Range("A1").CurrentRegion
    With DATOS
        Set FECHAS = .Columns(COLUMNA)
        Set DATOS = .Rows(2).Resize(.Rows.Count - 1, .Columns.Count)
        .Sort KEY1:=HT.Range(.Columns(COLUMNA).Address), ORDER1:=xlAscending
        CUENTA = WorksheetFunction.CountIfs(.Columns(COLUMNA), ">=" & FECHA_INICIAL, .Columns(COLUMNA), "<=" & FECHA_FINAL)
        On Error Resume Next
        FILA = WorksheetFunction.Match(CLng(CDate(fecha)), .Columns(COLUMNA), 0)
        If FILA = 0 Then
            MsgBox ("NO EXISTE UNA DE LAS FECHAS"), vbInformation, "AVISO"
            ListBox1.RowSource = Empty
            GoTo SALIDA:
        End If
        On Error GoTo 0
        Set INFO = .Rows(FILA).Resize(CUENTA, .Columns.Count)
        CommandButton1.Caption = CUENTA
        With ListBox1
            .RowSource = INFO.Address
            .ColumnCount = INFO.Columns.Count
            If COLUMNA = 5 Then .ColumnWidths = "65;200;20;65;60;40;300"
            If COLUMNA = 4 Then .ColumnWidths = "65;200;20;60;300"
        End With
    End With
End If
SALIDA:
End Sub

le hice pruebas pero creo que las que hagas tu validaran la funcionalidad de la macro.

Hola james.

Dejame tu mail si es posible y te envio el libro, porque a mi nada me da. La variable (si asi se llama) cuenta es para el textBox txtExistencia

txtExistencia.text = CUENTA

Pareciera que exije que la fecha sea exacta "pareciera" y la idea es que tu coloques una fecha inicial 9/6/2017  y fecha final 30/8/2017 y ENTRE esas 2 fechas te muestre los resultados encontrados de las fechas existentes ENTRE inicial y final.

Si entre inicial y final nada existe pues te dira que no existen registros, o si la inicial es mayor a la final, te diga que la inicial no puede ser mayor que la final

Entonces prueba esta macro no es más que una variación de la macro que colocaste con la diferencia que considera la columna donde esta la fecha según el botón que selecciones, pruébalas y en caso de que no funcione pon un email para mandarte el qrchivo con la macro.

Private Sub OptionButton1_Click()
CARGA
End Sub
Private Sub OptionButton2_Click()
CARGA
End Sub
Private Sub OptionButton3_Click()
CARGA
End Sub
Sub CARGA()
fecha_inicial = Format(DTPicker1, "mm/dd/yyyy")
fecha_final = Format(DTPicker2, "mm/dd/yyyy")
Set HF = Worksheets("FILTROS"): HF.UsedRange.Clear
CommandButton1.Caption = ""
If OptionButton1 = True Then
COLUMNA = Range("E1").Column
Set HT = Worksheets("PRODUCTO").Range("A1").CurrentRegion
End If
If OptionButton2 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("ENTRADAS").Range("A1").CurrentRegion
End If
If OptionButton3 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("SALIDAS").Range("A1").CurrentRegion
End If
If fecha_inicial = fecha_final Or fecha_inicial > fecha_final Then
    MsgBox ("LAS FECHAS NO PUEDEN SER IGUALES NI LA FECHA INICIAL PUEDE SER MAYOR QUE LA FECHA FINAL"), vbInformation, "AVISO"
Else
With HT
    .AutoFilter
    .AutoFilter Field:=COLUMNA, Criteria1:=">=" & fecha_inicial, Operator:=xlAnd, Criteria2:="<=" & fecha_final
    .SpecialCells(xlCellTypeVisible).Copy Destination:=HF.Range("A1")
    Set AREA = HF.Range("A1").CurrentRegion
    If AREA.Rows.Count = 1 Then
        MsgBox ("NO HAY REGISTROS EN ESE RANGO DE FECHAS"), vbInformation, "AVISO"
        ListBox1.RowSource = "": .AutoFilter: GoTo SALIDA
    End If
    With ListBox1
        .RowSource = "=FILTROS!" & Range("A1").CurrentRegion.Address
        .ColumnHeads = False
        .ColumnCount = HT.Columns.Count
        If COLUMNA = 5 Then .ColumnWidths = "65;200;20;65;60;40;300"
        If COLUMNA = 4 Then .ColumnWidths = "65;200;20;60;300"
    End With
    CommandButton1.Caption = AREA.Rows.Count - 1
End With
End If
SALIDA:
End Sub

Hola james, gracias una ves más por tu tiempo.

Quiero decirte que buena si sr. per pohay un problema que tal vez con conocimientos de causa, se pueda solucionar:

La primera ves que abro el formulario y filtro, filtra pero me oculta bastantes líneas después de filtrar, sea en que hoja sea.

Si quiero filtrar nuevamente ya no me filtra porque una grande mayoría de líneas están ocultas. ¿Quién pasa? Cierro el libro sin guardar y vuelvo a abrir para que vuelvan a aparecer las líneas totales.

Por lo demás si esta bien, aunque no funciona co nel button, si no que solo al marcar el option necesario

Probé la macro y le hice algunas modificaciones estas son las pantallas de los resultados, no me salí del libro sin grabarlo, probé los filtros varias veces cambiando de fechas y funciona bien.

Esta es la pantalla de la hoja producto

esta es la pantalla para la hoja entrada

esta es la pantalla salida

y este es el codigo modificado ahora corre presionando el boton comand

Private Sub CommandButton1_Click()
fecha_inicial = Format(DTPicker1, "mm/dd/yyyy")
fecha_final = Format(DTPicker2, "mm/dd/yyyy")
Set HF = Worksheets("FILTROS"): HF.UsedRange.Clear
CommandButton1.Caption = ""
If OptionButton1 = True Then
COLUMNA = Range("E1").Column
Set HT = Worksheets("PRODUCTO").Range("A1").CurrentRegion
End If
If OptionButton2 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("ENTRADAS").Range("A1").CurrentRegion
End If
If OptionButton3 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("SALIDAS").Range("A1").CurrentRegion
End If
If fecha_inicial = fecha_final Or fecha_inicial > fecha_final Then
    MsgBox ("HAY UN PROBLEMA" & Chr(13) & Chr(13) _
    & "1.- NO SELECCIONASTE UNA OPCION" & Chr(13) _
    & "2.- LA FECHA INICIAL ES MAYOR QUE LA FECHA FINAL") _
    , vbInformation, "AVISO"
Else
With HT
    On Error Resume Next
    .AutoFilter
    If Err.Number > 0 Then MsgBox ("no seleccionaste una opcion"), vbInformation, "AVISO": GoTo SALIDA
    On Error GoTo 0
    .AutoFilter Field:=COLUMNA, Criteria1:=">=" & fecha_inicial, Operator:=xlAnd, Criteria2:="<=" & fecha_final
    .SpecialCells(xlCellTypeVisible).Copy Destination:=HF.Range("A1")
    Set AREA = HF.Range("A1").CurrentRegion
    If AREA.Rows.Count = 1 Then
        MsgBox ("NO HAY REGISTROS EN ESE RANGO DE FECHAS"), vbInformation, "AVISO"
        ListBox1.RowSource = "": .AutoFilter: GoTo SALIDA
    End If
    With ListBox1
        .RowSource = "=FILTROS!" & Range("A1").CurrentRegion.Address
        .ColumnHeads = False
        .ColumnCount = HT.Columns.Count
        If COLUMNA = 5 Then .ColumnWidths = "65;200;20;65;60;40;300"
        If COLUMNA = 4 Then .ColumnWidths = "65;200;20;60;300"
    End With
    CommandButton1.Caption = AREA.Rows.Count - 1
    .AutoFilter
End With
End If
SALIDA:
End Sub

Hola James. Solo para que compruebes en que no te mentía lo que te mencione arriba sobre el ocultamiento de las filas

Sobre la última macro, si, en alguna oportunidad me hizo trampa, pero no se el porqué, pero funciona.

Pom ultimo quería que me dejaras el ListBox como lo tenía que me mostraba los títulos con su demarcación así y que no se mueven al jalar la barra vertical

NO así

Sin demarcación y se mueven al jalar la barra vertical tal vez algo en los rangos, digo yo que de macros no me contraten jejejjeej.

James, califico excelente, no podía ser otra, realmente tu dedicación fue, es algo extraordinario, lo cual no tengo como agradecerte desde Venezuela. Dejo la pregunta en stambay porque quiero ver como explicarte el fallo, Es que para que filtre tiene que estar en la hoja que marca el option, si no el filtro es incorrecto, si acaso estas en una hoja vacía de datos te presenta el ListBox así

Puedes ver que en la cantidad detectada, si acusa los datos totales de la hija Productos, pero si selecciono la hoja Productos, si muestra los resultados en el ListBox

Bien en ocasiones puede pasar que una macro funcione un poco diferente en equipos diferentes, no dudo que eso halla pasado en este caso ya lo he visto en otras ocasiones.

Dejame te explico algo hice la macro para que independientemente de la página donde estés cargue la información de las otras dos sin necesidad de moverse a esa página para eso son las instrucciones set ht=worksheets("producto"). Range("a1"). Currentregion, esto es decirle a la macro de que hoja y de que rango va a sacar la información para procesarla y mientras no cambies de opción la macro trabajara solo con esa hoja por eso a diferencia de la macro original no necesitas un código por cada página, eso hace un poco más eficiente la macro pero si lo que quieres es que la macro te lleve a esa página entonces en los if optionbutton... abajo de la orden set escribe esta línea sheets("producto").select o sheets("entradas").select....

Respecto a los encabezados del listbox y la página vacía te envío una macro con esas modificaciones, ahora te pondrá los encabezados que tenias y limpiara el commandbutton cuando la macro no encuentre datos.

Private Sub CommandButton1_Click()
fecha_inicial = Format(DTPicker1, "mm/dd/yyyy")
fecha_final = Format(DTPicker2, "mm/dd/yyyy")
Set hf = Worksheets("FILTROS"): hf.UsedRange.Clear
CommandButton1.Caption = ""
If OptionButton1 = True Then
COLUMNA = Range("E1").Column
Set HT = Worksheets("PRODUCTO").Range("A1").CurrentRegion
End If
If OptionButton2 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("ENTRADAS").Range("A1").CurrentRegion
End If
If OptionButton3 = True Then
    COLUMNA = Range("D1").Column
    Set HT = Worksheets("SALIDAS").Range("A1").CurrentRegion
End If
If fecha_inicial = fecha_final Or fecha_inicial > fecha_final Then
    MsgBox ("HAY UN PROBLEMA" & Chr(13) & Chr(13) _
    & "1.- NO SELECCIONASTE UNA OPCION" & Chr(13) _
    & "2.- LA FECHA INICIAL ES MAYOR QUE LA FECHA FINAL") _
    , vbInformation, "AVISO"
Else
With HT
    On Error Resume Next
    .AutoFilter
    If Err.Number > 0 Then MsgBox ("no seleccionaste una opcion"), vbInformation, "AVISO": GoTo SALIDA
    On Error GoTo 0
    .AutoFilter Field:=COLUMNA, Criteria1:=">=" & fecha_inicial, Operator:=xlAnd, Criteria2:="<=" & fecha_final
    .SpecialCells(xlCellTypeVisible).Copy Destination:=hf.Range("A1")
    Set AREA = hf.Range("A1").CurrentRegion
    If AREA.Rows.Count = 1 Then
        MsgBox ("NO HAY REGISTROS EN ESE RANGO DE FECHAS"), vbInformation, "AVISO"
        ListBox1.RowSource = "": .AutoFilter: CommandButton1.Caption = "": GoTo SALIDA
    End If
    Set filtra = hf.Range("a1").CurrentRegion
    Set filtra = filtra.Rows(2).Resize(filtra.Rows.Count, filtra.Columns.Count)
    With ListBox1
        .RowSource = "=FILTROS!" & filtra.Address
        .ColumnHeads = True
        .ColumnCount = HT.Columns.Count
        If COLUMNA = 5 Then .ColumnWidths = "65;200;20;65;60;40;300"
        If COLUMNA = 4 Then .ColumnWidths = "65;200;20;60;300"
    End With
    CommandButton1.Caption = AREA.Rows.Count - 1
    .AutoFilter
End With
End If
SALIDA:
End Sub

Estoy con Excel 2016

Edite esta respuesta, visto que al venir para dejarte respuesta vi tu ultimo aporte.

Fuy probando y deje la respuesta en stamby.

Vengo a decirte que esta esta mucho mejor, digamos que completa.

De todfos modos dejo la pregunta abierta por si algo aparece de raro jejejejje

Gracias James

Al aparecer este mensaje quisiera que el txtExistencia se limpiara

MsgBox ("NO HAY REGISTROS EN ESE RANGO DE FECHAS"), vbInformation, "AVISO"
txtExistencia.text = ""
Ya lo tengo en los Option
Private Sub OptionButton2_Click()
    txtExistencia.Text = ""
End Sub

para que se limpie cuando cambio de hoja