Jump to content

Antoni

Members
  • Content Count

    10,473
  • Joined

  • Last visited

  • Days Won

    604

Posts posted by Antoni

  1. En la hoja:

    Private Sub Worksheet_Change(ByVal Target As Range)
    '---------------------------------
    'Inserta la imagen de la columna A
    '---------------------------------
    If Target.Address Like "$A$*" Then InsertarImagen Target
    End Sub

    En un módulo:

    Sub InsertarImágenes()
    '--------------------------
    'Inserta todas las imágenes
    '--------------------------
    Dim x As Long
    For x = 8 To Range("A" & Rows.Count).End(xlUp).Row
       InsertarIagen Range("A" & x)
    Next
    End Sub
    '-------------------------------------------------------
    Sub InsertarImagen(Imagen As Range): On Error Resume Next
    Dim Archivo As String
    '------------------
    'Inserta una imagen
    '------------------
    Application.ScreenUpdating = False
    ActiveSheet.Shapes(Imagen.Address).Delete
    Imagen = ThisWorkbook.Path & "\Coches\" & Imagen.Value & ".jpg"
    ActiveSheet.Pictures.Insert(Archivo).Select
    With Selection.ShapeRange
       .LockAspectRatio = False
       .Name = Imagen.Address
       .Top = Imagen.Offset(0, 1).Top
       .Left = Imagen.Offset(0, 1).Left
       .Width = Imagen.Offset(0, 1).Width
       .Height = Imagen.Offset(0, 1).Height
    End With
    ActiveCell.Select
    Application.ScreenUpdating = True
    End Sub

    No me queda claro si también quieres obtener la lista de las imágenes de la carpeta Coches para luego validar la columna A.

  2. Para contraseñas de 4 posiciones:

    Ármate de paciencia, hay que probar con hasta cerca de 15.000.000 de posibilidades.

    Sub Desproteger(): On Error GoTo NoPass
    Dim L As String, Contraseña As String, Total As Long
    L = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    Debug.Print Time
    For A = 1 To Len(L): For B = 1 To Len(L): For C = 1 To Len(L): For D = 1 To Len(L)
       '------------------------------------------------------
       Total = Total + 1
       Contraseña = Mid(L, A, 1) & _
                    Mid(L, B, 1) & _
                    Mid(L, C, 1) & _
                    Mid(L, D, 1)
       ActiveSheet.Unprotect Password:=Contraseña
       If Contraseña <> "" Then
         Debug.Print Contraseña
         Debug.Print Time; Total
         Exit Sub
       End If
       '------------------------------------------------------
    Next: Next: Next: Next
    NoPass:
       Contraseña = ""
       Resume Next
    End Sub

     

  3. En los controles ActiveX en un formulario existe la propiedad .ControlTipText, pero en los controles insertados directamente en la hoja, no.

    Una solución bastante chapucilla consiste en insertar un label  junto al botón con el texto de ayuda, con la propiedad .Visible = False y luego haciendo click derecho sobre el botón para mostrarlo/ocultarlo de forma alternativa.

     

    Private Sub CommandButton1_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Label1.Visible = Not Label1.Visible
    End Sub

     

  4. Sub Combinar_Celdas()
       Application.ScreenUpdating = False
       Aplicar CDbl([K13]), CDbl([L13])
       Aplicar CDbl([K14]), CDbl([L14])
       Aplicar CDbl([K15]), CDbl([L15])
       Application.ScreenUpdating = True
    End Sub
    
    Sub Descombinar_Celdas()
       Application.ScreenUpdating = False
       Aplicar CDbl([K13]), CDbl([L13]), True
       Aplicar CDbl([K14]), CDbl([L14]), True
       Aplicar CDbl([K15]), CDbl([L15]), True
       Application.ScreenUpdating = True
    End Sub
    
    Private Sub Aplicar(K As Double, L As Double, Optional Descombinar As Boolean = False)
    For x = 8 To Range("C" & Rows.Count).End(xlUp).Row
       If Range("C" & x) = K Then i = x
       If Range("C" & x) = L Then f = x
       If i > 0 And f > 0 Then
          If Descombinar = False Then
             Range("D" & i & ":D" & f).Merge
             Range("E" & i & ":E" & f).Merge
             Range("F" & i & ":F" & f).Merge
             Range("G" & i & ":G" & f).Merge
          Else
             Range("D" & i & ":D" & f).UnMerge
             Range("E" & i & ":E" & f).UnMerge
             Range("F" & i & ":F" & f).UnMerge
             Range("G" & i & ":G" & f).UnMerge
          End If
          Exit Sub
       End If
    Next
    End Sub

     

  5. Lo mismo que ikanni, pero de otra forma.

    Selecciona el rango de celdas y ejecuta la macro.

    Sub ItalicText()
    For Each Texto In Selection
       With Texto
          i = InStr(.Value, "<i>")
          f = InStr(.Value, "</i>")
          If f > i And i > 0 Then
             .Value = Replace(.Value, "<i>", "")
             .Value = Replace(.Value, "</i>", "")
             .Characters(i, f - i - 3).Font.Italic = True
          End If
       End With
    Next
    End Sub

     

×
×
  • Create New...

Important Information

Privacy Policy