L'argomento di posizionamento immagini e loro dimensione è già stato ampiamente trattato e risolto in questo topic, leggi e prova, in caso di problemi posta ancora
ciao
Moderatori: Anthony47, Flash30005
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then GoTo salta
'macro esistente o chiamata alla macro
salta:
'altro eventuale codice
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) 'By Lanfre + PcFAcile
'
ListaF = Sheets("Parametri").Range("B2").Value '<<< Le celle con nome immagine
StdDir = Sheets("Parametri").Range("B3").Value: If Right(StdDir, 1) <> "\" Then StdDir = StdDir & "\"
DefPic = Sheets("Parametri").Range("B4").Value 'Dir e filename da usare in mancanza di foto
Jolly = Sheets("Parametri").Range("B5").Value 'Per decidere a quante colonne a destra
Alto = Sheets("Parametri").Range("B7").Value 'Altezza immagine e colonna
Largo = Sheets("Parametri").Range("B8").Value 'Larghezza immagine e colonna
Columns(Jolly + 1).ColumnWidth = (Largo) / 5.7 '* Da rivedere...
Rows.RowHeight = (Alto) + 4
For Each CELLA In Target
If Not Application.Intersect(CELLA, Range(ListaF)) Is Nothing Then
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & CELLA.Address(0, 0)).Delete
On Error GoTo 0
CELLA.Select
If (CELLA.Text <> "") Then
If Dir(StdDir & CELLA.Text & ".jpg") = "" Then
ActiveSheet.Pictures.Insert(DefPic).Select
Else
ActiveSheet.Pictures.Insert(StdDir & CELLA.Text & ".jpg").Select
End If
Selection.Name = "FOTO_DA_" & CELLA.Address(0, 0)
Selection.ShapeRange.Height = (Alto)
If Selection.ShapeRange.Width > (Largo) Then
Selection.ShapeRange.Width = (Largo)
End If
'PER POSIZIONARE L'IMMAGINE AL CENTRO DELLA CELLA CHE HO DECISO:
Selection.ShapeRange.Left = CELLA.Offset(0, (Jolly)).Left - Selection.ShapeRange.Width / 2 + CELLA.Offset(0, (Jolly)).Width / 2
Selection.ShapeRange.Top = CELLA.Offset(0, 0).Top - Selection.ShapeRange.Height / 2 + CELLA.Offset(0, (Jolly)).Height / 2
End If
CELLA.Select
End If
Next CELLA
End Sub
Sub INSERISCE_TUTTE_LE_IMMAGINI()
'Crea le immagini come da lista presente nel range ListaF
ListaF = Sheets("Parametri").Range("B2").Value '<<< Le celle con nome immagine
Application.GoTo (ActiveWorkbook.Sheets("IMMAGINI").Range("A1"))
For Each CELLA In Sheets("IMMAGINI").Range(ListaF)
OldV = CELLA.Value
CELLA.ClearContents: CELLA.Value = OldV
Next CELLA
End Sub
Sub CANCELLA_TUTTE_LE_IMMAGINI()
Cancel = Sheets("Parametri").Range("B6").Value 'Per decidere a quante colonne a destra cancellare
For Each pict In Sheets("IMMAGINI").Shapes
If pict.TopLeftCell.Column = Cancel Then pict.Delete
'pict.Delete 'SE VOGLIO CANCELLARE TUTTE LE IMMAGINI DAL FOGLIO METTERE APICE SU RIGA SOPRA E TOGLIERE DA PICT.DELETE
Next pict
End Sub
Sub INSERISCI_CARTELLA_IMMAGINI()
Application.GoTo (ActiveWorkbook.Sheets("Parametri").Range("B3"))
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.count = 0 Then
MsgBox ("Nessuna voce selezionata, procedura annullata")
GoTo Esci
End If
ActiveCell.Value = .SelectedItems.Item(1)
End With
Esci:
End Sub
Sub INSERISCI_IMMAGINE_NON_DISPONIBILE()
Application.GoTo (ActiveWorkbook.Sheets("Parametri").Range("B4"))
With Application.FileDialog(msoFileDialogFilePicker)
.Show
If .SelectedItems.count = 0 Then
MsgBox ("Nessuna voce selezionata, procedura annullata")
GoTo Esci
End If
ActiveCell.Value = .SelectedItems.Item(1)
End With
Esci:
End Sub
Sub DeleteAllVBACode()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Sub
Sub removeAllCode()
Dim awi 'activeWorkbookItem(index)
Dim awcl As Integer 'activeWorkbook Component CountOfLines
Dim count As Integer 'how many potential code modules
Dim i As Integer 'loop counter
On Error Resume Next
count = ActiveWorkbook.VBProject.VBComponents.count
For i = 1 To count
Set awi = ActiveWorkbook.VBProject.VBComponents.Item(i)
awcl = awi.CodeModule.CountOfLines
awi.CodeModule.DeleteLines 1, awcl
Next i
Set awi = Nothing ' Release the object
End Sub
Sub ESPORTA()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
TryAgain:
With Application.FileDialog(msoFileDialogSaveAs)
.Show
Flname = .SelectedItems.Item(1)
End With
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(2).Copy Before:=NewWkbk.Sheets(1)
removeAllCode 'DeleteAllVBACode
NewWkbk.SaveAs Flname
If Err.Number = 1004 Then
NewWkbk.Close
MsgBox "File Name Not Valid" & vbCrLf & vbCrLf & "Try Again."
GoTo TryAgain
End If
'ActiveWorkbook.Close
End If
End Sub
enricom ha scritto:facciamo che per A2 dipende da A1, A3 da B1 e A4 da C1.
enricom ha scritto:ho provato per es. ad inserire =SE(A1=1;"immagine1";"immagine2"),
Private Sub Worksheet_Change(ByVal Target As Range) 'By Lanfre + PcFAcile
'
If Target.Address <> "$A$1" Then Exit Sub '<<<<<<<<<<<<<< aggiungi questa riga qui, o copia tutta questa macro
ListaF = Sheets("Parametri").Range("B2").Value '<<< Le celle con nome immagine
StdDir = Sheets("Parametri").Range("B3").Value: If Right(StdDir, 1) <> "\" Then StdDir = StdDir & "\"
DefPic = Sheets("Parametri").Range("B4").Value 'Dir e filename da usare in mancanza di foto
Jolly = Sheets("Parametri").Range("B5").Value 'Per decidere a quante colonne a destra
Alto = Sheets("Parametri").Range("B7").Value 'Altezza immagine e colonna
Largo = Sheets("Parametri").Range("B8").Value 'Larghezza immagine e colonna
Columns(Jolly + 1).ColumnWidth = (Largo) / 5.7 '* Da rivedere...
Rows.RowHeight = (Alto) + 4
For Each CELLA In Target
If Not Application.Intersect(CELLA, Range(ListaF)) Is Nothing Then
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & CELLA.Address(0, 0)).Delete
On Error GoTo 0
CELLA.Select
If (CELLA.Text <> "") Then
If Dir(StdDir & CELLA.Text & ".jpg") = "" Then
ActiveSheet.Pictures.Insert(DefPic).Select
Else
ActiveSheet.Pictures.Insert(StdDir & CELLA.Text & ".jpg").Select
End If
Selection.Name = "FOTO_DA_" & CELLA.Address(0, 0)
Selection.ShapeRange.Height = (Alto)
If Selection.ShapeRange.Width > (Largo) Then
Selection.ShapeRange.Width = (Largo)
End If
'PER POSIZIONARE L'IMMAGINE AL CENTRO DELLA CELLA CHE HO DECISO:
Selection.ShapeRange.Left = CELLA.Offset(0, (Jolly)).Left - Selection.ShapeRange.Width / 2 + CELLA.Offset(0, (Jolly)).Width / 2
Selection.ShapeRange.Top = CELLA.Offset(0, 0).Top - Selection.ShapeRange.Height / 2 + CELLA.Offset(0, (Jolly)).Height / 2
End If
CELLA.Select
End If
Next CELLA
End Sub
Non capisco la macro che hai postato rispetto alla tua richiesta esempio ultima postata
enricom ha scritto:facciamo che per A2 dipende da A1, A3 da B1 e A4 da C1.
If Target.Address <> "$A$1" Then Exit Sub '<<<<<<<<<<<<<< aggiungi questa riga qui, o copia tutta questa macro
Private Sub Worksheet_Change(ByVal Target As Range) 'By Lanfre + PcFAcile
If Not Application.Intersect(Target, Range("A1:E1")) Is Nothing Then
Cella = Target.Column + 1
Foto = "A" & Cella
Call InsAutomatico
End If
End Sub
Public Foto
Sub InsAutomatico()
ListaF = Sheets("Parametri").Range("B2").Value '<<< Le celle con nome immagine
StdDir = Sheets("Parametri").Range("B3").Value: If Right(StdDir, 1) <> "\" Then StdDir = StdDir & "\"
DefPic = Sheets("Parametri").Range("B4").Value 'Dir e filename da usare in mancanza di foto
Jolly = Sheets("Parametri").Range("B5").Value 'Per decidere a quante colonne a destra
Alto = Sheets("Parametri").Range("B7").Value 'Altezza immagine e colonna
Largo = Sheets("Parametri").Range("B8").Value 'Larghezza immagine e colonna
Columns(Jolly + 1).ColumnWidth = (Largo) / 5.7 '* Da rivedere...
Rows.RowHeight = (Alto) + 4
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & Foto).Delete
On Error GoTo 0
Range(Foto).Select
If (Range(Foto).Text <> "") Then
If Dir(StdDir & Range(Foto).Text & ".bmp") = "" Then
ActiveSheet.Pictures.Insert(DefPic).Select
Else
ActiveSheet.Pictures.Insert(StdDir & Range(Foto).Text & ".bmp").Select
End If
Selection.Name = "FOTO_DA_" & Foto
Selection.ShapeRange.Height = (Alto)
If Selection.ShapeRange.Width > (Largo) Then
Selection.ShapeRange.Width = (Largo)
End If
'PER POSIZIONARE L'IMMAGINE AL CENTRO DELLA CELLA CHE HO DECISO:
Selection.ShapeRange.Left = Range(Foto).Offset(0, (Jolly)).Left - Selection.ShapeRange.Width / 2 + Range(Foto).Offset(0, (Jolly)).Width / 2
Selection.ShapeRange.Top = Range(Foto).Offset(0, 0).Top - Selection.ShapeRange.Height / 2 + Range(Foto).Offset(0, (Jolly)).Height / 2
End If
Range(Foto).Select
End Sub
enricom ha scritto:Ci ho dato uno sguardo veloce perchè non ho avuto molto tempo per soffermarmi come vorrei (lo farò sicuramente in questi giorni), ma per quello che ho visto mi sembra semplicemente: PERFETTO!!!
Grazie mille.
enricom ha scritto:Non l'ho fatto con quest'intento, ma credo che potrai adattarlo sicuramente.......
Appena ho un pò di tempo ti mando il file.
Ciao
ahidai ha scritto:enricom ha scritto:Non l'ho fatto con quest'intento, ma credo che potrai adattarlo sicuramente.......
Appena ho un pò di tempo ti mando il file.
Ciao
Grazie enricom per la risposta, e per il file. Ciao e buona giornata....
enricom ha scritto:Allora come è andata?
Sei riuscito ad adattare la macro?
Anthony47 ha scritto:sono gia' sul file excel, magari in un altro foglio in forma di "anagrafe" che incrocia parole e immagini".
Anthony47 ha scritto:Forse che si, forse che no...
Torna a Applicazioni Office Windows
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 6 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Excel 2016 - Funzione SCARTO + INDIRETTO Autore: pl1957 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 59 ospiti