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

Cargar userform según fecha

albersil

Recommended Posts

albersil Novato

albersil

publicado
publicado

Buenos días y gracias de antemano. Me estoy devanando los sesos y no consigo lo que necesito, que no es sino lo siguente:

Tengo dos libros de excel, cada uno de ellos, en un directorio diferente de una red. A saber:

H:\PROFESORES\ESTUDIOS\03_GESTION IPA\CURSO 2014_2015\DATOS\CUARTO\1CTR\RESUMEN.xls

H:\PROFESORES\ESTUDIOS\03_GESTION IPA\CURSO 2014_2015\DATOS\FECHAS LIMITE.xls

En la celda B5 DE FECHAS LIMITE.XLS pongo la fecha tope a partir de la que ya no se permitirá a los usuarios hacer uso del libro RESUMEN.xls.

La idea es que cuando se abra la hoja"RESUMEN" del libro RESUMEN.xls, el procedimiento Sub auto_open() lo primero que haga es comprobar la fecha actual del sistema con la que hay en la celda B5 de la hoja "Hoja1" del libro FECHAS LIMITE.XLS y que, mientras la fecha actual del sistema sea superior a la de la celda B5 aludida, muestre el userform Acceso.Show y en caso contrario que ejecute la funcion Sub Fechas_En_Letras() que pongo más abajo.

Como se puede ver lo he intentado pero he tenido que anular las filas usando ' porque me daban error. Lo siento pero no consigo hacerme con esto del VBA y por eso solicito vuestra ayuda, porque a lo mejor es más sencillo de lo que yo estoy tratando hacer. Salu2 y de nuevo gracias.

Sub auto_open()

Dim archivo As String

Dim carpeta As String

Dim r As Range

Dim i As Integer

Application.ScreenUpdating = False

Sheets(1).Visible = True

For i = 2 To Sheets.Count

Sheets(i).Visible = xlVeryHidden

Sheets(i).Protect "Miabuela1903"

ActiveWindow.DisplayWorkbookTabs = False

Next i

Sheets("RESUMEN").Protect "Miabuela1903"

Sheets("Clavesprof").Unprotect "Miabuela1903"

ActiveWindow.DisplayWorkbookTabs = False

Application.ScreenUpdating = True

'carpeta = "H:\PROFESORES\ESTUDIOS\03_GESTION IPA\CURSO 2014_2015\DATOS\"

'ChDir carpeta

'archivo = ("FECHAS LIMITE.xls")

' Workbooks.Open carpeta & archivo

'MsgBox ThisWorkbook

'If activWorkbook.Sheets("Hoja1").Range("B5") <> Date Then

'If ThisWorkbook.Sheets("Hoja1").Range("B5") <> Date Then 'Or _

'ThisWorkbook.Sheets("Hoja1").Range("B5") = "" Then

If Range("O2").Value = "" Then

Acceso.Show

Else

Fechas_En_Letras

End If

End Sub

Sub Fechas_En_Letras()

'ndia es el día de la semana que va desde 1 hasta 7.

ndia = Weekday((Range("O2").Value))

'numes es el número del mes que va desde 1 hasta 12.

nummes = Month((Range("O2").Value))

'diames es el día del mes que va desde 1 hasta 31.

diames = Day((Range("O2").Value))

'año es, evidentemente, el año de la fecha.

año = Year((Range("O2").Value))

Select Case nummes

Case 1

mes = "Enero"

Case 2

mes = "Febrero"

Case 3

mes = "Marzo"

Case 4

mes = "Abril"

Case 5

mes = "Mayo"

Case 6

mes = "Junio"

Case 7

mes = "Julio"

Case 8

mes = "Agosto"

Case 9

mes = "Septiembre"

Case 10

mes = "Octubre"

Case 11

mes = "Noviembre"

Case 12

mes = "Diciembre"

End Select

Select Case ndia

Case 1

dia = "Domingo"

Case 2

dia = "Lunes"

Case 3

dia = "Martes"

Case 4

dia = "Miercoles"

Case 5

dia = "Jueves"

Case 6

dia = "Viernes"

Case 7

dia = "Sabado"

End Select

MsgBox "Usted tenía hasta el " & dia & " " & diames & " de " & mes & " de " & año & " para calificar." & vbCrLf & _

vbCrLf & "Ahora ya no puede introducir datos.", vbCritical, "CALIFICACIÓN IPAs"

End Sub

albersil Novato

albersil

publicado
  • Autor
publicado

Bueno a veces las hojas de los árboles no te dejan ver el bosque. Me contesto yo mismo. Se me ha encendido la luz y con este código me funciona, aunque seguramente los expertos lo harían de forma más eficaz. Gracias de todas formas. Lo pongo por si a alguien le sirve:

Sub auto_open()

Dim archivo As String

Dim carpeta As String

Dim r As Range

Dim i As Integer

Application.ScreenUpdating = False

Sheets(1).Visible = True

For i = 2 To Sheets.Count

Sheets(i).Visible = xlVeryHidden

Sheets(i).Protect "Miabuela1903"

ActiveWindow.DisplayWorkbookTabs = False

Next i

Sheets("RESUMEN").Protect "Miabuela1903"

Sheets("Clavesprof").Unprotect "Miabuela1903"

ActiveWindow.DisplayWorkbookTabs = False

carpeta = "H:\PROFESORES\ESTUDIOS\03_GESTION IPA\CURSO 2014_2015\DATOS\"

ChDir carpeta

archivo = ("FECHAS LIMITE.xls")

Workbooks.Open carpeta & archivo

If ActiveWorkbook.Sheets("Hoja1").Range("B5") >= Date _

Or ActiveWorkbook.Sheets("Hoja1").Range("B5") = "" Then

ActiveWorkbook.Close

ActiveWorkbook.Save

ThisWorkbook.Activate

Acceso.Show

Else

ActiveWorkbook.Close

ActiveWorkbook.Save

ThisWorkbook.Activate

Fechas_En_Letras

End If

Application.ScreenUpdating = True

End Sub

Archivado

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

Ir al listado de temas

  • 109 ¿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

  • Current Donation Goals

    • Mantenimiento de la comunidad
      Raised 0.00 EUR of 130.00 EUR target

  • Archivos

  • Estadísticas de descargas

    • Archivos
      187
    • Comentarios
      97
    • Revisiones
      29
    Más información sobre "Un juego del Rabino en Excel"
    Última descarga
    Un juego del Rabino en Excel
    Por pegones1

    2    1

  • Crear macros Excel

  • Mensajes

    • JSDJSD
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por JSDJSD · publicado

      'Opción 1 Sub FiltrarSKUPorFecha(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim diccionarioSKU As Object Dim listaEliminar As Object Dim fechaActual As String, fechaSiguiente As String Dim f As Variant With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Crear diccionarios para comparar SKU y almacenar filas a eliminar Set diccionarioSKU = CreateObject("Scripting.Dictionary") Set listaEliminar = CreateObject("Scripting.Dictionary") ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then diccionarioSKU.RemoveAll ' Limpiar el diccionario antes de llenarlo ' Guardar los SKU de la fecha siguiente (solo de la siguiente) For f = fila + 1 To ultimaFila If .Cells(f, 1).Value <> fechaSiguiente Then Exit For diccionarioSKU(.Cells(f, 2).Value) = 1 Next f ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Solo eliminar si el SKU no está en la fecha siguiente If Not diccionarioSKU.exists(.Cells(f, 2).Value) Then listaEliminar(f) = 1 ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar.keys .Rows(f).Delete Next End With MsgBox "Completado correctamente.", vbInformation End Sub 'Opción 2 Sub FiltrarSKUPorFecha1(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim listaEliminar As Collection Dim fechaActual As String, fechaSiguiente As String Dim f As Variant, i As Long Dim SKUExiste As Boolean With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Inicializar la colección para marcar las filas a eliminar Set listaEliminar = New Collection ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Comprobar si el SKU está en la fecha siguiente SKUExiste = False For i = fila + 1 To ultimaFila If .Cells(i, 1).Value <> fechaSiguiente Then Exit For If .Cells(i, 2).Value = .Cells(f, 2).Value Then SKUExiste = True Exit For End If Next i ' Si el SKU no se encuentra en la fecha siguiente, marcar para eliminar If Not SKUExiste Then listaEliminar.Add f ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar .Rows(f).Delete Next f End With MsgBox "Completado correctamente.", vbInformation End Sub   TABLA ELIMINAR.xlsm
    • JSDJSD
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por JSDJSD · publicado

      Prueba y comenta 
    • Israel Cassales
      AYUDA PARA EXTRAER INFORMACIÓN ESPECIFICA DE UNA COLUMNA

      Por Israel Cassales · publicado

      Es una idea espero sea de ayuda productos.xlsb
    • Israel Cassales
      AYUDA PARA EXTRAER INFORMACIÓN ESPECIFICA DE UNA COLUMNA

      Por Israel Cassales · publicado

      Hola a ambos, Comparto lo que dice el maestro Victor, no está clara la consulta en cuanto a las definiciones, si tuviera que deducir las piezas son el resultado de la multiplicación posterior a los gramos, como los ejemplos son botanas es posible que sean cajas por piezas. Si es el caso, una opción es convertir ese texto a una operación matemática después de extraerlo. Para esto se puede definir una función de EVALUAR que no siempre esta disponible pero se puede mandar llamar en la definición de los nombres. Por otro lado hay múltiples "p" que estorban un poco, (Principe ChocoBlanco EmpBco 12p 126g FLOW MLA) así que yo recomendaría definir nombres y segmentar las funciones, no es complicado aunque tal vez requiera un poco de experiencia del usuario si quiere editar en lo futuro. Tal vez con eso sería suficiente dando un resultado similar a lo siguiente:
    • JSDJSD
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por JSDJSD · publicado

      Perfecto, mañana lo intento

  • 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.