Visualizza immagine con condizione

[BG66]

Ciao a tutti.
Selezionando il titolo in B1 vorrei che in A1 venga visualizzata l'immagine specifica presente nella riga 15 (foglio di lavoro "DB") ottimizzata come dimensione.
Esempio: in schede commerciale scelgo : Titolo 2 e in A1 compare l'immagine con nome 231.
https://www.swisstransfer.com/d/881ec37b-8907-4711-9a94-b5ab72f1798f

Grazie in anticipo.
Gene

[Anthony47]

Avevamo gia’ avuto una richiesta simile che avresti potuto adattare a questo caso, vedi viewtopic.php?f=26&t=113559#p668349
Comunque penso che questa macro dovrebbe fare quanto richiesto:

Codice: Seleziona tutto

Sub CopyLogo()
Dim LogoSh As Worksheet, TitRow As Long, PicRow As Long
Dim hMatch, Shp As Shape
'
Set LogoSh = Sheets("DB")
TitRow = 11
PicRow = 15
Application.EnableEvents = False
'Cancella immagini in A1:
For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Or Shp.Type = msoLinkedPicture Then
        If Shp.TopLeftCell.Address = "$A$1" Then
            Shp.Delete
        End If
    End If
Next Shp
'Cerca la nuova immagine
Range("A1").Clear
hMatch = Application.Match(Range("B1"), LogoSh.Cells(TitRow, 1).Resize(1, 1000), False)
If Not IsError(hMatch) Then
    LogoSh.Cells(PicRow, hMatch).Copy Range("A1")
Else
    MsgBox ("Nessun match per: " & Range("B1"))
End If
Application.EnableEvents = True
End Sub


Se funziona magari puoi associarla a all’evento Worksheet_Change
Prova...

PS: Ma c'e' un passaggio generazionale in corso?

[BG66]

Ma c'e' un passaggio generazionale in corso?

Ciao Anthony. No, purtroppo c'è solo il rincoglionimento di una persona anziana...lo scrivente!!
Più tardi faccio la prova e ti do conferma.

Gene

[BG66]

Ciao
Fatta prova. Ovviamente funziona.

Per l'associazione all’evento Worksheet_Change, mi sono mosso così:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo CleanExit
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(False, False) <> "B1" Then Exit Sub

    Application.EnableEvents = False
    Call CopyLogo

CleanExit:
    Application.EnableEvents = True
    If Err.Number <> 0 Then
        MsgBox "Errore: " & Err.Number & " - " & Err.Description
    End If
End Sub

[Anthony47]

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo CleanExit
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(False, False) <> "B1" Then Exit Sub
    Application.EnableEvents = False
    Call CopyLogo
CleanExit:
    Application.EnableEvents = True
    If Err.Number <> 0 Then
        MsgBox "Errore: " & Err.Number & " - " & Err.Description
    End If
End Sub


Un po’ surdimensionato per la situazione da gestire...

Se si parte dall’assunzione che la Call deve essere fatta quando target.address=B1 non ha senso controllare che target.count sia =1
Come pure L’OnError serve a gestire niente (gli errori nella routine chiamata non vengono riportati al chiamante); e piuttosto che un msgbox che ferma tutto meglio limitarsi a un ripristinare gli eventi e non fare altro

Io mi sarei limitato a:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("B1")) Is Nothing Then
    Application.EnableEvents = False
    Call CopyLogo
    Application.EnableEvents = True
End If
End Sub


Piuttosto mi accorgo che sarebbe meglio non cercare nessun logo se Titolo e’ vuoto; quindi suggerisco di aggiungere all’interno della Sub CopyLogo un livello di If come da questo nuovo codice:

Codice: Seleziona tutto

Sub CopyLogo()
Dim LogoSh As Worksheet, TitRow As Long, PicRow As Long
Dim hMatch, Shp As Shape
'
Set LogoSh = Sheets("DB")
TitRow = 11
PicRow = 15
Application.EnableEvents = False
'Cancella immagini in A1:
For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Or Shp.Type = msoLinkedPicture Then
        If Shp.TopLeftCell.Address = "$A$1" Then
            Shp.Delete
        End If
    End If
Next Shp
'Cerca la nuova immagine
Range("A1").Clear
If Range("B1") <> "" Then
    hMatch = Application.Match(Range("B1"), LogoSh.Cells(TitRow, 1).Resize(1, 1000), False)
    If Not IsError(hMatch) Then
        LogoSh.Cells(PicRow, hMatch).Copy Range("A1")
    Else
        MsgBox ("Nessun match per: " & Range("B1"))
    End If
End If
Application.EnableEvents = True
End Sub


[BG66]

@Anthony
Grazie per i consigli e i suggerimenti che mi ricordano sempre "Less is more".

Alla prossima... memoria permettendo

Gene
PS Un saluto sempre e comunque al mio tutor @Marius44 che questa volta non si è appalesato