Saltar al contenido

Recommended Posts

publicado

Hola a todos:

Estoy siguiendo una serie, no recuerdo bien, pero creo que en National Geographic, que se titula,"La Tierra sin nosotros", en la que se relata como sería el mundo si desapareciera la raza humana, pues bien, yo os propongo lo siguiente:

Que pasaría, si de repente, en nuestras macros, no pudieramos utilizar las funciones de cadena.

Como sería una "simple instrucción" tal que:

Libro = Mid(Right(Fichero, Len(Fichero) - Len(ThisWorkbook.Path) + 1))
[/CODE]

En primer lugar, desde dentro hacia fuera, necesitamos averiguar la longitud de Fichero y de ThisWorkbook.Path.

He desarrollado esta función, con la inestimable colaboración de [b]neverdelimon1[/b], para hallar la longitud de un texto, no pretendo que sea, ni la única, ni la mejor, ni la mas rápida, por lo que se agradece de antemano cualquier modificación.

[b][size=4]FUNCION LEN[/size][/b]

[CODE]Function xLen(Texto As Variant)
On Error GoTo Salida
Dim Cadena() As Byte, UboundCadena As Integer
'Obtenemos la longitud del texto
'-------------------------------
Cadena = Texto
While UboundCadena = UboundCadena
If Cadena(UboundCadena) > 0 Then xLen = xLen + 1
UboundCadena = UboundCadena + 1
Wend
Salida:
End Function
[/CODE]

Algunos os preguntareis, ¿Y para que?, pues en primer lugar, por pura diversión y en segundo lugar, para que los que empiezan ahora, que no han tenido la suerte de tener que empezar a programar desde abajo, vean que en cada instrucción de un lenguaje de alto nivel, se esconde un montón de código que es transparente para ellos.

Os animo a que participeis y envieis vuestras versiones de Left, Right, Mid, Split, Replace,........

¡ Ah ! Recordad que no podeis usar ninguna función de cadena en vuestras aportaciones (excepto Chr y similares).

Salu2 a to2222222222 to 22222222.

Antoni.

publicado

Antoni muy buena tu propuesta, gracias por compartirla y con tu permiso modifico ligeramente tu UDF para que haga referencia a una celda [porque segun lo que revise solo funciona cuando se ingresa el texto directamente "xLen("gerson") ]

Function xLen2(Texto As Range)
On Error GoTo Salida
Dim Cadena() As Byte, UboundCadena As Integer
'Obtenemos la longitud del texto
'-------------------------------
Cadena = Texto
While UboundCadena = UboundCadena
If Cadena(UboundCadena) > 0 Then xLen2 = xLen2 + 1
UboundCadena = UboundCadena + 1
Wend
Salida:
End Function[/PHP]

Saludos desde Honduras

publicado

Hola Gerson:

La forma de llamar a la función dentro de una macro, sería:

Longitud = xLen(Texto)[/CODE]

Pero el aporte no está pensado para ser usado, si no para ilustrar lo que nos ahorramos de escribir con la función LEN de VBA, que por supuesto, será infinitamente mas simple y mas rápida.

Salu2. Antoni.

publicado

Mas simple, si valen errores y contadores de array, quedaria asi:

Public Function zLen(rango() As Byte)
On Error GoTo output
For i = 1 To 2 ^ 15: rango(i) = 0: Next
output:
MsgBox i / 2
End Function[/CODE]

En realidad esto tendria sentido si estuvieramos hablando de C#, en VB hay muchisimo mas detras, al asignar la cadena al array es cuando se crea el valor de Len e incluso si este no se usa seguira existiendo como valor del propio objeto, y aun que no lo uses manualmente en el codigo el bucle si que lo usa por que si no, ¿Como demonios iba a saber de que longitud tiene que crear el array?

Realmente lo que se esta haciendo aqui es, usar LEN (disimuladamente) para asignar su valor a la longitud de un array, recorrer todo el array y capturar el error que se produce cuando se intenta escribir fuera de ese rango. Si lo piensas bien, esto no tiene mucho sentido. Pero bueno, mejor que hacer un sudoku no?, Parece que no soy el unico que se aburre ...ja...ja..

Saludos

publicado

Hola DRAMIDOM:

Llegarás, no te preocupes, si sabemos mas no es por listos, si no por viejos, o porqué empezamos antes.

Saludos. Antoni.

publicado
Hola DRAMIDOM:

Llegarás, no te preocupes, si sabemos mas no es por listos, si no por viejos, o porqué empezamos antes.

Saludos. Antoni.

Si ya se, es como el niño que empieza gateando y ya pretente correr jeje... Pero bien solo observo a modo de aprender del conocimiento de los demas.

publicado

El merito es de Never, que fue quien me indicó como.

¡ Ah ! mucha suerte para hoy, que si ganais, nos ahorramos 15 millones de euros en primas a los jugadores.

Salu2. Antoni.

publicado

Hola

Desde luego que todo el merito es para el master Antoni (porque a mi ni se me hubiera ocurrido jejejejejej).

Y ya que estamos entrando en el pasado y puesto que no estamos tomando en cuenta el rendimiento ni nada por el estilo, que tal un bucle simulado, de los primeros que nos permitia VB de hace ya muchos antaños.

 Function xLen(Texto As Variant) As Integer
0 On Error Resume Next
1 Dim Cadena() As Byte, UboundCadena As Integer
2 'Obtenemos la longitud del texto
3 '-------------------------------
4 Cadena = Texto
5 Cadena(UboundCadena) = Cadena(UboundCadena)
6 If Err.Number = 0 Then
7 If Cadena(UboundCadena) > 0 Then xLen = xLen + 1
8 UboundCadena = UboundCadena + 1
9 GoTo 5 'bucle simulado
10 End If
11 End Function
Sub test()
0 ' Para probar la funcion anterior
1 Dim a As Integer
2 a = xLen("Hola Antoni")
3 MsgBox "Número de caracteres: " & a, vbInformation
4 End Sub[/CODE]

Saludos cordiales

publicado

Hola a todos:

Hoy en que pasaría si no existiera,..... la función:

Find

Dim Celda, Desde As Long, Hasta As Long, Fila As Long, x As Integer
Sub Buscar(Valor)

'Solo admitimos selecciones de 1 Area y 1 Columna
If Selection.Areas.Count > 1 Or _
Selection.Columns.Count > 1 Then Exit Sub

'Inicializamos variables
Desde = 100000
Hasta = 0

'Buscamos 1ª celda y última celda
For Each Celda In Selection
If Celda.Row > Hasta Then Hasta = Celda.Row
If Celda.Row < Desde Then Desde = Celda.Row
Next

'Busqueda dicotómica
While Hasta - Desde > 1
Fila = Desde + Int((Hasta - Desde) / 2)
If ActiveSheet.Cells(Fila, ActiveCell.Column) = Valor Then
ActiveSheet.Cells(Fila, ActiveCell.Column).Select
Exit Sub
End If
If ActiveSheet.Cells(Fila, ActiveCell.Column) < Valor Then
Desde = Fila
Else
Hasta = Fila
End If
Wend

End Sub
[/CODE]

Este procedimiento busca un valor en una rango de celdas seleccionado, [b]ORDENADO DE MENOR A MAYOR[/b].

Proporciona solamente una coincidencia, seleccionando la celda.

En caso de muchas coincidencias, no se puede garantizar cual será el seleccionado.

Sea cual sea la cantidad de celdas del rango, se garantiza que el numero de iteraciones hasta conseguir o no la coincidencia, será menor de [b]Logaritmo en base 2 del numero de celdas que contenga el rango + 1[/b], así por ejemplo, una búsqueda entre 12.000 celdas se realizará en un máximo de 20 iteraciones.

Salu2. Antoni.

Conéctate para comentar

Podrás dejar un comentario después de conectarte



Conéctate ahora
  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

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


      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR
  • Archivos

  • Estadísticas de descargas

    • Archivos
      188
    • Comentarios
      98
    • Revisiones
      29

    Más información sobre "Cambios en el Control Horario"
    Última descarga
    Por pegones1

    4    1

  • Crear macros Excel

  • Mensajes

    • Hola, veo que tienes 365, así que esta forma funcionará   Almacen.xlsx
    • Buenos días  @LeandroA espero estes bien Tengo un caso idéntico al planteado en la siguiente pregunta: Sin embargo, a diferencia de quien planteo originalmente la pregunta al correr el código no obtengo ningún resultado podrían ayudarme a resolver este inconveniente y que al hacer click en el Botón Guardar (CommandButton3) del Formulario RCS (frmrcs) el archivo pdf quede configurado con orientación vertical, márgenes superior, inferior, derecho e izquierdo = 1 y en página tamaño carta. Si acaso influye uso Microsoft Excel LTSC MSO (versión 2209 Compilación16.0.1.15629.20200) de 64 bits Mucho le sabre agradecer la ayuda que me pueda dar  RCS PRUEBA - copia.xlsm
    • @JSDJSDCon gusto mi estimado Para la opción 1: Sub Surtirhastadondealcanse() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 4 Dim filaFin As Integer: filaFin = 7 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Else solicitudes(i) = 0 End If surtido(i) = "POR FALTA STOCK" Next i ' Surtir de acuerdo al inventario disponible For i = 1 To numClientes If solicitudes(i) > 0 Then If inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) ElseIf inventario > 0 Then surtido(i) = inventario totalSurtido = totalSurtido + inventario inventario = 0 Else surtido(i) = "POR FALTA STOCK" End If End If Next i ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = "POR FALTA STOCK" Then .Value = surtido(i) .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Para la opción 2:   Sub surtirenpartesiguales() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 13 Dim filaFin As Integer: filaFin = 16 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 Dim totalPedido As Double: totalPedido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) totalPedido = totalPedido + solicitudes(i) Else solicitudes(i) = 0 End If surtido(i) = 0 Next i ' Si hay suficiente inventario, surtir lo que el cliente pide If inventario >= totalPedido Then For i = 1 To numClientes If solicitudes(i) > 0 And inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) End If Next i Else ' Reparto base igualitario Dim baseSurtido As Long baseSurtido = Int(inventario / numClientes) For i = 1 To numClientes If solicitudes(i) > 0 Then If solicitudes(i) <= baseSurtido Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) Else surtido(i) = baseSurtido inventario = inventario - baseSurtido totalSurtido = totalSurtido + baseSurtido End If End If Next i ' Repartir sobrante restante uno por uno, respetando lo pedido Do While inventario > 0 For i = 1 To numClientes If surtido(i) < solicitudes(i) Then surtido(i) = surtido(i) + 1 totalSurtido = totalSurtido + 1 inventario = inventario - 1 If inventario = 0 Then Exit For End If Next i Loop End If ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = 0 Then .Value = "POR FALTA STOCK" .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Saludos, Diego
    • Buenos dias.  Estoy trabajando en una hoja para poder llevar un control de un pequeño almacén.  Tengo un pedido con varias líneas y "lotes" y necesito sacar las ubicaciones que coincidan con la referencia y lote que pone en el pedido. El problema viene cuando tengo la misma referencia y mismo lote en ubicaciones diferentes y necesito sacar la información en columnas diferentes. No se si  me he explicado bien, pero creo que con el ejemplo adjunto se entiende mejor. Agradecería mucho si me pudieran ayudar  Libro1.xlsx
    • Exelente solución mil gracias 
  • 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.