Ahora sí, aquí lo dejo por si a alguien le viene bien.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim celda As Range
Dim imgNombre As String
Dim imgOriginal As Shape
Dim imgCopia As Shape
Dim nombreImagenCelda As String
' Solo actuar si el cambio es en una celda individual
If Target.CountLarge > 1 Then Exit Sub
Set celda = Target
nombreImagenCelda = "Imagen_" & celda.Address(False, False)
' Eliminar imagen existente en esa celda (si existe con ese nombre)
On Error Resume Next
Me.Shapes(nombreImagenCelda).Delete
On Error GoTo 0
' Determinar qué imagen usar según el valor
Select Case celda.Value
Case 1: imgNombre = "PruebaEuropa"
Case 2: imgNombre = "PruebaAsia"
Case 3: imgNombre = "PruebaÁfrica"
Case 4: imgNombre = "PruebaAmérica"
Case 5: imgNombre = "PruebaOceanía"
Case 6: imgNombre = "PruebaMarrón"
Case Else: Exit Sub ' No hacer nada si el valor no es válido
End Select
' Buscar la imagen original
On Error Resume Next
Set imgOriginal = Me.Shapes(imgNombre)
On Error GoTo 0
If imgOriginal Is Nothing Then
MsgBox "No se encontró la imagen '" & imgNombre & "'.", vbExclamation
Exit Sub
End If
' Copiar la imagen y colocarla sobre la celda
imgOriginal.Copy
Me.Paste
Set imgCopia = Me.Shapes(Me.Shapes.Count)
With imgCopia
.Top = celda.Top
.Left = celda.Left
.Height = celda.Height
.Width = celda.Width
.LockAspectRatio = msoFalse
.Name = nombreImagenCelda
End With
End Sub
Por
Maku, · publicado
Buenas tardes, espero puedan ayudar... De ante mano muchas gracias.
-Tengo una macro que me copia la hoja en la cual trabajo y la renombra (Perfecto)**
Lo que necesito:
-Mensaje Yes/No "¿Desea guardar e Imprimir esta solicitud?"
-No: sigo trabajando, Yes: Copia hoja, guarda e imprime.
-Y por ultimo que limpie las cerdas de la hoja matriz.
Estas:
Range("D10:F10,A13:A28,C13:F28").Select
Range("D10:F10,A13:A28,C13:F28,A49:A64,C49:F64").Select
Selection.ClearContents
Observación: deseo bloquear la hoja pero con lo que tengo ya trabajado, me da un error.
GRACIAS POR SU AYUDA
Macro que copia y renombra:
Sub Botón4_Haga_clic_en()
Dim hoja As Worksheet
Dim existe As Boolean
Dim nueva As String
nueva = ActiveSheet.Name & Sheets.Count - 1
If nueva = Empty Then Exit Sub
For Each hoja In Worksheets
If hoja.Name = nueva Then existe = True
Next hoja
Application.DisplayAlerts = False
If existe = False Then
Sheets("Solicitud No.").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = nueva
.Tab.Color = 16711680
.Shapes("Button 1").Delete
End With
MsgBox "Se Guardo Correctamente"
Sheets("Solicitud No.").Select
End If
Application.DisplayAlerts = True
Exit Sub
MsgBox "Ya existe una hoja con ese nombre."
End Sub