Saltar al contenido
Te enseño 7 de los trucos que me permitieron trabajar 2 horas menos al día >>>

Los "N..." mejores (formulario)

Gerson Pineda

Por Gerson Pineda
en Ideas y aportes

Recommended Posts

Gerson Pineda Mentor

Gerson Pineda

publicado
publicado

Hola a todos!

Hoy quiero compartir con ustedes, un archivo que muestra los "n" mejores... de una tabla, por medio de un formulario, este consiste en que deseamos ver dentro del formulario, segun el numero de "top" que elegimos, mejor vean el adjunto y ojala le sirva a alguien:)

Nota: en relaidad es un filtro mejorado (comodo) y adaptado a un formulario

Cualqiuer mejora o algo mejor pues aqui esperamos:D

Private Sub TextBox1_Change()

    Dim uf

    Application.ScreenUpdating = False
    On Error Resume Next

    With Sheets("sheet1")

        Cells.Rows.Hidden = False
        ListBox1.RowSource = Empty
        If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
        End If
        Range("A32").CurrentRegion.ClearContents

        If TextBox1 <= 0 Then
            MsgBox "Indique el Top porfavor... debe ser mayor a 0"
            ListBox1.RowSource = Empty
            If ActiveSheet.FilterMode Then
            ActiveSheet.ShowAllData
            End If
            Range("A32").CurrentRegion.ClearContents
            TextBox1 = ""
            Me.TextBox1.SetFocus
            Exit Sub
        End If

        If Me.TextBox1 <> "" Then
        With Range("A1").CurrentRegion
            .AutoFilter 3, TextBox1, xlTop10Items
            .Copy
            With .SpecialCells(xlCellTypeVisible)
            Range("A32").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Range("A1").Select
            End With
        End With
        Me.TextBox1.SetFocus
        End If

        ListBox1.RowSource = "A32:C100"

        uf = Cells(65536, 1).End(xlUp).Row
        For g = 32 To uf
            If Cells(g, 1) <> "" Then Rows(g).Hidden = True
        Next

    End With

    On Error GoTo 0
    Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click()

    ListBox1.RowSource = Empty
    If ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
    End If
    Range("A32").CurrentRegion.ClearContents
    TextBox1 = ""
    Me.TextBox1.SetFocus
    Exit Sub

End Sub[/PHP]

Saludos desde Honduras

Los 5 mejores.zip

Enlace a comentario
Compartir con otras webs
himself Novato

himself

publicado
publicado

Re: Los "n" mejores (formulario)

Saludos a todos, gracias por mostrarnos este formidable codigo, muy bueno.

Tengo una duda, a ver si me pueden aclarar.

Si deseara que los Tops se ordenaran descendentemente, que deberia cambiar?

Otra cosa, al buscar los 4 Tops, en lugar de 4 muestra 5. Donde podria buscar el fallo?

Gracias y disculpas por la curiosidad :)

Enlace a comentario
Compartir con otras webs
Gerson Pineda Mentor

Gerson Pineda

publicado
  • Autor
publicado

Re: Los "n" mejores (formulario)

Macro (antes Antoni jejeje, porque te cambiaste el nombre???), gracias por tus comentarios, y las lineas a las cuales haces mencion son muy utiles para no ir al menu de Excel, es muy practico, si encuentra el modo filtro muestra todos los datos

himself como estas

Si deseara que los Tops se ordenaran descendentemente, que deberia cambiar?

Otra cosa, al buscar los 4 Tops, en lugar de 4 muestra 5. Donde podria buscar el fallo?

Segun tu primera pregunta, he adaptado y cambiado un poco la macro (espero te guste) y la segunda tienes razon, pero como Excel tiene muchas curiosidades, una de ellas es esta, y don Excel los muestra porque hay dos valores iguales (64) en dos registros, prueba cambiando uno de ellos a 63 o 65, y vuelve a filtrar y notaras el cambio....

Mi estimado Luis

Por los momentos tengo que salir corriendo... y no tengo mas tiempo para describir la macro, pero en futuros aportes tratare de hacerlo, aunque mencionarte que es a libre voluntad para quienes lo deseen hacer (yo por mi lado con gusto, ya sabes a la orden)

Adjunto de nuevo el aporte y espero que agrade mas, y si hay mas mejoras pues adelante que nos servira a todos

Saludos desde Honduras

Los 5 mejores.zip

Enlace a comentario
Compartir con otras webs
himself Novato

himself

publicado
publicado

Re: Los "n" mejores (formulario)

Muchas gracias por la respuesta, Gerson Pineda-El Catracho.

De verdad que cuando veo personas como tu, llenas de conocimiento y con tanto deseo de enseñar, me dan mas ganas de superarme y hacer lo mismo. Muchas gracias a cada uno de los que aqui, nos ayudan a crecer, cada dia mas, sin pedir nada a cambio. Mucho exito a todos.

Enlace a comentario
Compartir con otras webs
Gerson Pineda Mentor

Gerson Pineda

publicado
  • Autor
publicado

Re: Los "n" mejores (formulario)

Hola de nuevo

A peticion de mi amigo Luis

Private Sub TextBox2_Change()

    'Declarar la variable uf
    Dim uf

    'Desactivar el parpadeo de la pantalla
    Application.ScreenUpdating = False

    'Saltar cualquier error
    On Error Resume Next

    'Seleccionar la hoja para filtrar
    With Sheets("Filtro")

        'Mostrar cualquier fila escondida
        Cells.Rows.Hidden = False

        'Limpiar el listbox
        ListBox1.RowSource = Empty

        'Desactivar si el filtro esta modo activo y mostrar los registros
        If ActiveSheet.FilterMode Then
            ActiveSheet.ShowAllData
        End If

        'Marcar el rango desde A32 hasta donde existan datos (hacia la derecha y hacia abajo) _
        o sea el rango usado, limapiar y quitar color de celdas
        With Range("A32").CurrentRegion
            .Clear
            .Interior.Color = xlNone
        End With

        'Si el textbox es menor o igual a cero, que proceda...
        If Me.TextBox2.Value <= 0 Then
            MsgBox "Indique el Top porfavor... debe ser mayor a 0"
            Cells.Rows.Hidden = False
            ListBox1.RowSource = Empty
            If ActiveSheet.FilterMode Then
                ActiveSheet.ShowAllData
            End If
            With Range("A32").CurrentRegion
                .Clear
                .Interior.Color = xlNone
            End With
            'Limpiar el textbox y activar cursor en el mismo
            Me.TextBox2 = ""
            Me.TextBox2.SetFocus
            Exit Sub
        End If

        'Si el textbox es diferente a campo vacio
        If Me.TextBox2.Value <> "" Then
        With Range("A1").CurrentRegion
            'Filtrar por la columna C, segun el Top/Mejor numero
            .AutoFilter 3, Me.TextBox2.Value, xlTop10Items
            .Copy
            'Pegar solo los datos visibles, desde A32
            With .SpecialCells(xlCellTypeVisible)
            Range("A32").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            'Ordenar los datos pegados, segun el orden ingresado
            With Range("A32").CurrentRegion
                .Sort Range("C33"), Me.TextBox1.Value, Header:=xlGuess
            End With
            Range("A1").Select
            End With
        End With
        End If

        'Mostrar los datos en el listbox
        ListBox1.RowSource = "A32:C100"

        'Crear el siclo o bucle para ocultar las filas que se muestran en listbox (para estetica)
        uf = Cells(65536, 1).End(xlUp).Row
        For g = 32 To uf
            If Cells(g, 1) <> "" Then Rows(g).Hidden = True
        Next

    End With

    'Anular o desactivar cualquier error inniciado
    On Error GoTo 0
    'Activar la pantalla
    Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    ListBox1.RowSource = Empty
    Cells.Rows.Hidden = False
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
    End If
    With Range("A32").CurrentRegion
        .Clear
        .Interior.Color = xlNone
    End With
    Me.TextBox1 = ""
    Me.TextBox2 = ""
    Me.TextBox1.SetFocus
    Exit Sub
    Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Initialize()
'Al iniciar el fornulario, activar el cursor en el textbox
Me.TextBox1.SetFocus
End Sub

Private Sub TextBox1_Change()
'Si el numero para ordenar los datos es mayor a 2, que proceda...
If Me.TextBox1.Value > 2 And Me.TextBox1.Value <> "" Then
    MsgBox "Ingrese solamente: el # 1 (orden ascendente) o # 2 (orden descendente)"
    Me.TextBox1 = ""
    Me.TextBox2 = ""
    Me.TextBox1.SetFocus
    Exit Sub
End If
End Sub
[/PHP]

Y subo el archivo, le agregue algo mas para restringir la entrada de valores...:)

Saludos desde Honduras

Los 5 mejores _.zip

Enlace a comentario
Compartir con otras webs
Fleming Novato

Fleming

publicado
publicado

Re: Los "n" mejores (formulario)

Hola Gerson

Aunque en estos momentos mis conocimientos de VBA son muy rudimentarios, valoro tu trabajo y disposición a ayudar (que vienen siendo tus señas de identidad). Esta contribución tuya - me guío por las palabras de Luis y Himself - tiene que ser muy importante para la programación, por lo que la tendré muy en cuenta cuando progrese en macros y alcance a comprenderla.

Un saludo

Enlace a comentario
Compartir con otras webs
Gerson Pineda Mentor

Gerson Pineda

publicado
  • Autor
publicado

Re: Los "n" mejores (formulario)

Muchas gracias por la respuesta, Gerson Pineda-El Catracho.

De verdad que cuando veo personas como tu, llenas de conocimiento y con tanto deseo de enseñar, me dan mas ganas de superarme y hacer lo mismo. Muchas gracias a cada uno de los que aqui, nos ayudan a crecer, cada dia mas, sin pedir nada a cambio. Mucho exito a todos.

himself de verdad gracias por tus comentarios y elogios... asi que ya sabes

Saludos

Enlace a comentario
Compartir con otras webs
  • 5 years later...
Ricardo Palacios Novato

Ricardo Palacios

publicado
publicado

hola amigo gerson.

Primeramente te saludo, y admiro tus conocimiento, por lo cual solicito tu ayuda en el desarrolo de mi problema.

Mira yo tengo archivo con dos Hojas Hoja1 y Hoja2 y un formulario en la cual esta un listbox de una hoja1 que con solo cliquear me carga en los textbox, lo que necesito es que cuando escriba en el textbox lo filtre en el listbox y nuevamente cliqueando en el listbox cargue los datos ya filtrados te dejo el codigo ya que no se puede cargar el archivo, agradezco de ante mano tu apoyo.

Private Sub CommandButton1_Click()
Dim fila As Integer
'No pude seleecionar la hoja Datos, pero si escribir directamente diciéndole el lugar.
With Worksheets("StandBy")
     fila = .Range("A" &amp; Cells.Rows.Count).End(xlUp).Offset(1).Row
     .Range("B" &amp; fila) = ComboBox3.Value
     .Range("C" &amp; fila) = TextBox2.Value
     .Range("E" &amp; fila) = TextBox4.Value
     .Range("H" &amp; fila) = TextBox7.Value
     .Range("F" &amp; fila) = TextBox5.Value
     .Range("A" &amp; fila) = TextBox8.Value
     .Range("I" &amp; fila) = TextBox10.Value
     .Range("G" &amp; fila) = ComboBox1.Value
     .Range("D" &amp; fila) = ComboBox2.Value
End With
MsgBox ("DATOS TRANSFERIDOS")
' Limpia los campos de la entrada de los textbox
Me.ComboBox3.Value = ""
Me.TextBox2.Value = ""
Me.TextBox4.Value = ""
Me.TextBox7.Value = ""
Me.TextBox5.Value = ""
Me.TextBox10.Value = ""
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Rem Textbox1.SetFocus Envía el cursor al Textbox1 para volver a capturar los datos
ComboBox3.SetFocus
End Sub

Private Sub CommandButton2_Click()
UserForm2.Hide
End Sub

Private Sub ListBox1_Click()
fila = ListBox1.ListIndex + 2
    With Hoja6.Range(ListBox1.RowSource)
        TxtFiltro1.Text = .Offset(ListBox1.ListIndex, 0).Resize(1, 1).Value
        TextBox4.Text = .Offset(ListBox1.ListIndex, 1).Resize(1, 1).Value
    End With
End Sub

Private Sub TxtFiltro1_Change()
Application.ScreenUpdating = False '&lt;---  adaptacion
nombre = Val(TextBox1)
Sheets("Stock StandBy").Unprotect
Sheets("Stock StandBy").Activate
Cells.EntireRow.Hidden = False
uf = Range("A" &amp; Cells.Rows.Count).End(xlUp).Row
If nombre = "" Then Exit Sub
'==========================adaptacion===============================
ListBox1.RowSource = "": ListBox1.ColumnCount = 3
Dim Datos(1000, 2) 'dimensiones de la matriz
Dim matriz_1 As Integer
matriz_1 = -1
For fil = 0 To uf

    If Range("a" &amp; fil + 2) &lt;&gt; nombre Then
            'oculta las filas
            Rows(fil + 2 &amp; ":" &amp; fil + 2).EntireRow.Hidden = True
            GoTo line1
        Else 'si es igual,entonces
            'agrega los datos a la matriz
           matriz_1 = matriz_1 + 1
           For j = 0 To 7
            Datos(matriz_1, j) = Cells(fil + 2, j + 1)

           Next j
    End If
line1:
Next fil

ListBox1.List = Datos 'carga el listbox con la matriz(24 filas y 4 col)
'depura el listbox con datos vacios 
'For i = ListBox1.ListCount - 1 To 0 Step -1
'   On Error Resume Next
'   If ListBox1.List(i).Column(2) &lt;&gt; Val(TextBox1) Then ListBox1.RemoveItem (i)
'Next
'========================fin de adaptacion===========================
Sheets("Stock StandBy").Protect
Sheets("Reguistro").Activate

End Sub

Private Sub UserForm_Activate()
TextBox8 = Date

End Sub

Private Sub UserForm_Initialize()
'mostramos hoja2
Hoja6.Visible = xlSheetVisible
Hoja6.Select
Me.ListBox1.Clear
'cargamos los datos del inventario en el listbox1
Me.ListBox1.RowSource = "a5:c" &amp; Hoja6.Range("A" &amp; Rows.Count).End(xlUp).Row
With ListBox1
    'le decimos cuantas columnas tine
    .ColumnCount = 3
    'le decimos que tiene encabezado
    .ColumnHeads = True
    'le decimos los espacios para los datos
    .ColumnWidths = "180 pt;60 pt;70 pt"
End With
'ocultamos la hoja2
Hoja6.Visible = xlSheetVeryHidden
'refrescamos pantalla
Application.ScreenUpdating = True
End Sub

Atte.

Palacios

Enlace a comentario
Compartir con otras webs
Gerson Pineda Mentor

Gerson Pineda

publicado
  • Autor
publicado
te adjunto el archivo, para mas detalles gracias
Hola Ricardo

Gracias por tus comentarios y se bienvenido pero por favor lee las normas del foro (por varias razones)

Una de las razones principales es que en esta sección no se hacen consultas

Saludos

Se nota que no leíste mis comentarios

Saludos

Enlace a comentario
Compartir con otras webs

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas

  • 96 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • Sí
      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Mantenimiento de la comunidad
      Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR

  • Archivos

  • Estadísticas de descargas

    • Archivos
      177
    • Comentarios
      90
    • Revisiones
      27

  • Crear macros Excel

  • Mensajes

    • jues
      Convertidor de Unidades

      Por jues · publicado

      Saludos amigos espero estén bien Estoy intentando hacer un formulario que me convierta unidades de masa sin embargo  en el mejor de los casos solo he podido lograr la conversión de una unidad a la vez en los TextBox 1, 3, 5, 7, 9, 11 y 13 y cuando lo logro el resultado que se copia  en la celda no se corresponde con el obtenido originalmente en el Textbox del Formulario (frmconv)  ejemplo al convertir 1900 Kg a Lb el resultado en el TextBox1 =4188,78298142 sin embargo al guardar el resultado lo que se copia en la Celda  "F11" es  418.878.298.142,00, adicionalmente el resultado de la conversión no se visualiza inmediatamente por lo que debo de hacer click en los TextBox 1, 3, 5, 7, 9, 11 y 13  para ver el resultado. Mucho les sabre agradecer la ayuda que me puedan brindar. PRUEBA.xlsm
    • Israel Cassales
      Hacer formulas auto incrementales

      Por Israel Cassales · publicado

      Saludos a ambos. Copiar y pegar por sí solas, no tengo el conocimiento de que sirvan como "evento" para actualizar las referencias que buscas hacer, en la forma que lo quieres hacer, ó la fórmula como la quieres hacer. Te recomiendo abrir un tema similar en Macros, es posible que algún Maestro te de alguna idea. Por otro lado, si debe ser con funciones, entonces tendías que interactuar con COLUMNA() y FILA() para que al pegar el destino "sepa" donde está ubicado e intentar cambiar la referencia. =INDIRECTO(CARACTER(COLUMNA()+64)&FILA()) Algo como eso se podría usar para obtener el código ASCII de la letra de la columna (donde 65 es el código para “A”), y FILA() devuelve el número de la fila. La función CARACTER() convierte el código ASCII en una letra. Luego, INDIRECTO() toma la cadena resultante (por ejemplo, “A1”, “B2”, etc.) y la usa como una referencia de celda. En ese caso, una posible idea de editar tu ejemplo sería: =SI(INDIRECTO("'Casos de Prueba'!"&CARACTER(COLUMNA()+64)&"1")="Resultados Ciclo 1"; SI(CONTAR.SI(INDIRECTO("'Casos de Prueba'!"&CARACTER(COLUMNA()+64)&":"&CARACTER(COLUMNA()+64)); "OK")=0; 0; CONTAR.SI(INDIRECTO("'Casos de Prueba'!"&CARACTER(COLUMNA()+64)&":"&CARACTER(COLUMNA()+64)); "OK")); 0)   Enfatizo que es una idea, es muy probable que haya que editar. Así como esta su tema, la recomendación del maestro toma relevancia porque especular o deducir no es lo adecuado para intentar ayudar en este tipo de consultas. Por esta causa de mi parte por ejemplo no puedo aportar algo adicional.
    • JSDJSD
      avanzar una celda hacia abajo apartir de una celda seleccionada

      Por JSDJSD · publicado

      En el ejemplo te he puesto 1 segundo para no hacer largo el gif, cámbialo a tu necesidad
    • JSDJSD
      avanzar una celda hacia abajo apartir de una celda seleccionada

      Por JSDJSD · publicado

      Sub RecorrerRangoC() Set hoja = ActiveSheet Set rango = hoja.Range("C2:C" & hoja.Cells(hoja.Rows.Count, "C").End(xlUp).Row) If rango.Cells.Count = 0 Then MsgBox "No hay datos en la columna C.", vbExclamation Exit Sub End If For Each celda In rango.SpecialCells(xlCellTypeVisible) celda.Select Application.Wait Now + TimeValue("00:00:01") Next celda End Sub Prueba y comenta
    • Pirtrafilla
      Hacer una operación usando una tabla de configuración

      Por Pirtrafilla · publicado

      Gracias   Al final funciona con esta formula. =SI.ERROR(C5*BUSCARV(A$2;TablaReparto[#Todo];COINCIDIR(D5;TablaReparto[#Encabezados];));C5) En la celda C5 he puesto la OT. Es similar a lo que me das como solución. ¡Muchas gracias por la ayuda!  

  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.