Inserire più immagini su excel in ordine

Question

Ho un foglio excel con 1000 righe contenenti codici alfanumerici tutti diversi.

Il foglio è diviso in due colonne: "A" per quanto riguarda i codici e "B" per quanto riguarda l'immagine corrispondente.

Come faccio per inserire l'immagine corrispondente ad ogni riga?

I codici sono in ordine alfabetico e anche le immagini dato che TUTTE hanno il nome del codice corrispondente.

Il risultato dovrebbe essere questo:

ABC1234abc1234	immagine_ABC1234abc1234
DEF5678def5678	immagine_DEF5678def5678
GHI1234ghi1234	immagine_GHI1234ghi1234

Capirete che i codici sono 1000! Non posso inserire le immagini una ad una...

Answer 1

Ciao John,

Ho un foglio excel con 1000 righe contenenti codici alfanumerici tutti diversi.

Il foglio è diviso in due colonne: "A" per quanto riguarda i codici e "B" per quanto riguarda l'immagine corrispondente.

Come faccio per inserire l'immagine corrispondente ad ogni riga?

I codici sono in ordine alfabetico e anche le immagini dato che TUTTE hanno il nome del codice corrispondente.

Il risultato dovrebbe essere questo:

ABC1234abc1234	immagine_ABC1234abc1234
DEF5678def5678	immagine_DEF5678def5678
GHI1234ghi1234	immagine_GHI1234ghi1234

Capirete che i codici sono 1000! Non posso inserire le immagini una ad una...

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim myPic As Picture

    Dim sStr As String

    Dim LRow As Long

    Dim CalcMode As Long

    Const sNomeFoglio As String = "Foglio1"              '<<=== Modifica

    Const sPercorsoImagine As String = _

                         "**C:\Users\Ndj\Documents**"             '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sNomeFoglio)

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set Rng = .Range("A1:A" & LRow)

    End With

    For Each rCell In Rng.Cells

        With rCell

            sStr = sPercorsoImagine & .Value & ".jpg"

            Set myPic = SH.Pictures.Insert(sStr)

            myPic.Top = .Offset(0, 1).Top

            myPic.Left = .Offset(0, 1).Left

            .RowHeight = myPic.Height

        End With

    Next rCell

XIT:

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman

Answer 2

Grazie ora il lavoro è completo!

Answer 3

Ciao John,

Grazie sei stato gentilissimo. Sono riuscito nell'impresa con una piccola modifica al tuo codice.

Bene!

Ho notato però che per far visualizzare le immagini devo portare con me la cartella dove sono contenute...

non c'è un modo per farle stare dentro il file excel?

Certo, a patto che si utilizzi il metodo Shapes.AddPicture e che si precisi True per i valori del secondo  argomento (LinkToFile) e il terzo parametro (SaveWithDocument).    

Quindi, prova a sostituire il codice precedente con qualcosa del genere: 

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim myPic As Shape

    Dim aStr As String, sStr As String

    Dim LRow As Long

    Const sNomeFoglio As String = "Foglio1"                        '<<=== Modifica

    Const sPercorsoImagine As String = _

                    "C:\Users\Ndj\Documents**"                           '<<=== Modifica**

    Const sExt As String = ".jpg"                                              '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sNomeFoglio)

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set Rng = .Range("A1:A" & LRow)

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    For Each rCell In Rng.Cells

        aStr = rCell.Value & sExt

        sStr = sPercorsoImagine & aStr

        Set myPic = SH.Shapes.AddPicture( _

                    Filename:= _

                    sStr, _

                    LinkToFile:=True, _

                    SaveWithDocument:=True, _

                    Left:=100, _

                    Top:=100, _

                    Width:=70, _

                    Height:=70)

        With myPic

            .ScaleHeight 1#, True, msoScaleFromTopLeft

            .ScaleWidth 1#, True, msoScaleFromTopLeft

        End With

        With rCell

            myPic.Top = .Offset(0, 1).Top

            myPic.Left = .Offset(0, 1).Left

            .RowHeight = myPic.Height

        End With

    Next rCell

XIT:

Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<=========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm o xlsb
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman

Answer 4

Grazie sei stato gentilissimo. Sono riuscito nell'impresa con una piccola modifica al tuo codice.

Ho notato però che per far visualizzare le immagini devo portare con me la cartella dove sono contenute...

non c'è un modo per farle stare dentro il file excel?