Ciao draleo,
prova a guardare il file modificato in questo modo.
Ho inserito un "Foglio2" dove in colonna C ho inserito il testo che dovrebbe rappresentare la didascalia.
In colonna D ho inserito il testo che dovrebbe rappresentare la categoria.
A mio parere, visto che devi fare il lavoro di "categoriazzazione" a questo punto conviene "raccogliere" anche questo dato nel file.
In corrispodenza dello spazio della didascalia viene inserito il testo presente in colonna C.
La procedura inoltre crea, sotto il precedente spazio dedicato alle didascalie, un analogo spazio dove viene inserito il contenuto presente nel corrispondente rigo dellla colonna D (a cui ho anteposto una stringa di testo, dichiarata come una constante, composta da cinque "trattinibassi" (o underscore).
Le lettere delle colonne anch'esse le ho dichiarate tramite una costante così nel caso basterà modificare la lettera della colonna nel caso venisse spostata.
Queste sono le nuove dichiarazioni di costanti e variabili relative a queste modifiche:
'---
Const sNomeWsDidascalie As String = "Foglio2"
Const sColDidascalie As String = "C"
Const sColCategorie As String = "D"
Const sUnderScoreCategoria As String = "_____"
Dim wsDidascalie As Worksheet
'---
Questo è il solito file di esempio.
https://www.dropbox.com/s/zk7jt8idgl7qtgj/VBA%20caricare%20immagini%20jpg%20in%20un%20foglio%20Excel.xlsm?dl=0
Riporto comunque anche tutto il codice (anche se ti verrà più comodo copiarlo direttamente dal VBA del file).
'---
Option Explicit
'<--- dichiarazioni constanti per inserimento immagini e didascalie - start
Const PercorsoImmagini As String = "C:\tmpImmagini\"
Const NumeroPrimaImmagineIniziale As Long = 1
Const NumeroImmaginiDaCaricare As Long = 60
Const NumImmaginiPerRiga As Long = 4
Const NumImmaginiPerPagina As Long = 20
Const PassoCol As Long = 20
Const DeltaPassoRighe As Long = 25
Const DeltaRigheCambioPagina As Long = 7 '8
Const NumColIniziale As Long = 7
Const NumRigheDidascalie As Long = 2
Const NumColDidascalie As Long = PassoCol
'dichirazioni costanti per inserimento immagini e didascalie - end --->
'<--- dichiarazioni variabili per inserimento immagini e didascalie - start
Dim Immagine As Object
Dim i As Long, NumCol As Long, PassoRighe As Long
Dim NumeroPrimaImmagine As Long, NumeroUltimaImmagine As Long
Dim ContatoreImmaginiPerRiga As Long, ContatoreImmaginiPerPagina As Long
Dim stringaEccezioneNumerica As String
'dichiarazioni variabili per inserimento immagini e didascalie - start --->
'<--- dichiarazioni costanti e variabili per bordi e inserimento descrizioni numeri pagina
Const sRngTitolo As String = "AH1:BG4"
Const PrimaRigaBordo As Long = 5
Const PrimaColonnaBordo As Long = NumColIniziale - 1
Const UltimaColonnaBordo As Long = NumColIniziale + (NumImmaginiPerRiga * PassoCol)
Const PassoRigheBordo As Long = (DeltaPassoRighe * (NumImmaginiPerPagina / NumImmaginiPerRiga)) + 1
Const NumRigheNumPag As Long = 2
Const NumColNumPag As Long = 14
Const offsetColonneNumPag As Long = 4
Const offsetColonneDescrAnno As Long = 64
Dim NumeroPagine As Long
Dim iPrimaRigaBordo As Long, iUltimaRigaBordo As Long, iPassoRigheBordo As Long
Dim iSottrattore As Long
'<--- dichiarazioni costanti e variabili relative al foglio dove sono presente le descrizioni delle didascalie e categorie
Const sNomeWsDidascalie As String = "Foglio2"
Const sColDidascalie As String = "C"
Const sColCategorie As String = "D"
Const sUnderScoreCategoria As String = "_____"
Dim wsDidascalie As Worksheet
Sub InserimentoImmaginiMain()
Application.ScreenUpdating = False
Call CancellaImmagini
Call InserisciImmaginiIV
Call ImpostaBordiENumerazionePagine
Application.ScreenUpdating = True
End Sub
Sub InserisciImmaginiIV()
Set wsDidascalie = ThisWorkbook.Worksheets(sNomeWsDidascalie)
Call CancellaImmagini
NumeroPrimaImmagine = NumeroPrimaImmagineIniziale
NumeroUltimaImmagine = NumeroPrimaImmagine + NumeroImmaginiDaCaricare - 1
NumCol = NumColIniziale
PassoRighe = 0
ContatoreImmaginiPerRiga = 0
ContatoreImmaginiPerPagina = 0
stringaEccezioneNumerica = vbNullString
EccezioneNumerica:
For i = NumeroPrimaImmagine To NumeroUltimaImmagine
'<--- inserimento immagini senza eccezione numerica - start
Select Case CStr(i & stringaEccezioneNumerica) '<=== indicare qui i numeri delle immagini "fittizie"
Case 5, 10, 29, 38
'Non viene fatto nulla!!!!
Case Else
Set Immagine = ActiveSheet.Pictures.Insert(PercorsoImmagini & i & stringaEccezioneNumerica & ".JPG")
With Immagine
.Name = "Immagine " & i & stringaEccezioneNumerica
'.Height = 80
.Width = 121
.Top = ActiveSheet.Cells(DeltaPassoRighe + PassoRighe, NumCol).Top + _
ActiveSheet.Cells(DeltaPassoRighe + PassoRighe, NumCol).RowHeight - .Height
.Left = ActiveSheet.Cells(DeltaPassoRighe + PassoRighe, NumCol).Left
'<--- con questi comandi unisco le celle al di sotto dell'immagine (2 righe e 12 colonne) _
e inserisco una "didascalia" _
N.B. ora ho impostato il numero di colonne pari alla costante NumColDidascalie attualmente _
Posta pari al passo colonne. _
Anche il numero righe viene impostato tramite una constante NumRigheDidascalie.
With ActiveSheet.Cells(DeltaPassoRighe + PassoRighe, NumCol)
With .Offset(1, 0).Resize(NumRigheDidascalie, NumColDidascalie)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
With .Font
.Name = "Calibri"
.Size = 9
.Italic = True
End With
.Merge
.Value = wsDidascalie.Range(sColDidascalie & i) '"Immagine " & i & stringaEccezioneNumerica '& ".JPG"
End With
With .Offset(3, 0).Resize(NumRigheDidascalie, NumColDidascalie)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
With .Font
.Name = "Calibri"
.Size = 9
.Italic = True
End With
.Merge
.Value = sUnderScoreCategoria & wsDidascalie.Range(sColCategorie & i) & sUnderScoreCategoria
'"Immagine " & i & stringaEccezioneNumerica '& ".JPG"
End With
End With
'--->
End With
End Select
ContatoreImmaginiPerRiga = ContatoreImmaginiPerRiga + 1
ContatoreImmaginiPerPagina = ContatoreImmaginiPerPagina + 1
If ContatoreImmaginiPerRiga = NumImmaginiPerRiga Then
ContatoreImmaginiPerRiga = 0
NumCol = NumColIniziale
If ContatoreImmaginiPerPagina = NumImmaginiPerPagina Then
ContatoreImmaginiPerPagina = 0
PassoRighe = PassoRighe + DeltaPassoRighe + DeltaRigheCambioPagina
Else
PassoRighe = PassoRighe + DeltaPassoRighe
End If
Else
NumCol = NumCol + PassoCol
End If
'inserimento immagini senza eccezione numerica - end --->
'<--- inserimento immagini con eccezione numerica - start
If stringaEccezioneNumerica = vbNullString Then
Select Case i
Case 0 '<=== inserire i numeri per cui è presente una eccezione numerica
stringaEccezioneNumerica = "A"
NumeroPrimaImmagine = i
NumeroUltimaImmagine = NumeroUltimaImmagine - 1
GoTo EccezioneNumerica '<= rimando "spaghetti code"
End Select
End If
stringaEccezioneNumerica = vbNullString
'inserimento immagini con eccezione numerica - end --->
Next i
End Sub
Sub ImpostaBordiENumerazionePagine()
NumeroPagine = Application.RoundUp(NumeroImmaginiDaCaricare / NumImmaginiPerPagina, 0)
iPassoRigheBordo = 0
With ActiveSheet
For i = 1 To NumeroPagine
If i = 1 Then
iSottrattore = 1
Else
iSottrattore = 0
End If
If i > 1 Then iPassoRigheBordo = iUltimaRigaBordo + 1
iPrimaRigaBordo = PrimaRigaBordo + iPassoRigheBordo
iUltimaRigaBordo = iPrimaRigaBordo + PassoRigheBordo - iSottrattore
'Debug.Print .Range(.Cells(iPrimaRigaBordo, PrimaColonnaBordo), .Cells(iUltimaRigaBordo, UltimaColonnaBordo)).Address
With .Range(.Cells(iPrimaRigaBordo, PrimaColonnaBordo), .Cells(iUltimaRigaBordo, UltimaColonnaBordo))
'<--- inserimento bordi
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End With
'formattazione celle per inserimento numerazione pagina, inserimento numero pagina e _
inserimento interruzione di pagina
With .Cells(iUltimaRigaBordo, PrimaColonnaBordo)
With .Offset(1, offsetColonneNumPag).Resize(NumRigheNumPag, NumColNumPag)
.Merge
.Value = "Pagina " & i & "/" & NumeroPagine
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "Calibri"
.Size = 8
End With
End With
With .Offset(1, offsetColonneDescrAnno).Resize(NumRigheNumPag, NumColNumPag)
.Merge
.Value = "anno XXXX" 'anno da individuare in base ad una data condizione come ad es. un intervallo di immagini
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "Calibri"
.Size = 8
End With
End With
End With
.HPageBreaks.Add Before:=.Cells(iUltimaRigaBordo, PrimaColonnaBordo).Offset(3, 0) 'interruzioni di pagina
Next i
With .Range(sRngTitolo)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "Algerian"
.Size = 20
End With
.Value = "Titolo"
End With
End With
End Sub
Sub CancellaImmagini()
Dim shp As Shape
'<--- n.b. per mia semplicità cancello tutte le celle per ripristinare per ogni nuovo inserimento.
' da valutare nel caso specifico come modificare
With ActiveSheet
.Cells.Clear 'Contents
.ResetAllPageBreaks
End With
'n.b. nel foglio ho un "pulsante modulo" nominato "Pulsante" e ho impostato la condizione di _
cancellare tutte le immagini tranne quella nominata "Pulsante"
For Each shp In ActiveSheet.Shapes
With shp
If .Name <> "Pulsante" Then .Delete
End With
Next shp
End Sub
Sub RinominaImmagini()
Dim fso As Object
Dim file As Object
Dim fsofiles As Object
Dim i As Long
Set fso = CreateObject("scripting.filesystemobject")
Set fsofiles = fso.getfolder(PercorsoImmagini).Files
i = 0
On Error Resume Next
For Each file In fsofiles
i = i + 1
Name file As PercorsoImmagini & i & ".jpg"
Next file
End Sub
'---
