Současný kód co mám funguje tak, že zapisuji po jedné buňce, potřeboval bych ho předělat na hromadné vložení. Pokud to jde.
Děkuji všem za pomoc.
Kód: Vybrat vše
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cmnt As Excel.Comment, DiskPath As String, Extsn As String
' je zmena v pozadovane oblasti bunek
If Intersect(Target, Me.Range("Q2:Q1000")) Is Nothing Then Exit Sub
' redukce na jednu bunku (napr. pri mazani vice bunek)
Set Target = Target.Resize(1, 1)
' disk a cesta, rozsireni
DiskPath = "Z:\\"
Extsn = ".jpg"
With Target.Offset(0, -12) 'kde 2 znamena ze se komentar vlozi o dve bunky do prava.
.ClearComments
' bunka je prazdna
If Target.Value = vbNullString Then Exit Sub
Set Cmnt = .AddComment
'vlozi obrazek podle nazvu v bunce
'a formatuje komentar
With Cmnt
On Error Resume Next
.Shape.Fill.UserPicture DiskPath & .Parent.Offset(0, 12).Value & Extsn
' osetreni chyby pri odkazu na obrazek
If Err.Number <> 0 Then
'*vyber si moznost odstranenim a pridanim apostrofu k prislusnemu radku, zde prvni moznost*
' bud bez vlozeni prazdneho komentare
'Target.ClearComments: GoTo ErrHandler
' nebo vlozeny komentar se sdelenim
.Text Text:="Obrazek nebyl nalezen"
'**********************************
End If
On Error GoTo 0
' nastavit rozmery komentare
.Shape.Height = 450 ' vyska
.Shape.Width = 650 ' sirka
' zobrazeni komentare pouze pri najeti kurzoru na bunku = False nebo trvale = True
.Visible = False ' True
End With
End With
ErrHandler:
Set Cmnt = Nothing
End Sub