Prosím o pomoc.
Jendá se o:
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cmnt As Excel.Comment, DiskPath As String, Extsn As String, Zmena As Range, ARE As Range, Bunka As Range, H(), Pocet As Long
' je zmena v pozadovane oblasti bunek
Set Zmena = Intersect(Target, Range("A1:A100"))
If Zmena Is Nothing Then Exit Sub
' disk a cesta, pripona
DiskPath = "C:\Users\"
Extsn = ".jpg"
Application.ScreenUpdating = False
' Smazat pripadne stare komentare
Zmena.Offset(, 2).ClearComments
' projit vsechny skupiny oblasti
For Each ARE In Zmena
With ARE
Pocet = .Cells.Count
ReDim H(1 To Pocet, 1 To 1)
' nacist data zmeny pro celou skupinu
If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1
' projdi vsechny bunky v cilove oblasti pro komentare
For Each Bunka In .Offset(, 2).Cells 'kde -12 znamena ze se komentar vlozi o 12 bunek do leva.
' vlozi komentar kdyz neni datova bunka prazdna
If Not IsEmpty(H(Pocet, 1)) Then
'vlozi obrazek podle nazvu v bunce
'a formatuje komentar
With Bunka.AddComment
On Error Resume Next
.Shape.Fill.UserPicture DiskPath & H(Pocet, 1) & Extsn
' osetreni chyby pri odkazu na obrazek
If Err.Number <> 0 Then .Text Text:="Obrazek nebyl nalezen"
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 If
Pocet = Pocet + 1
Next Bunka
End With
Next ARE
Application.ScreenUpdating = True
Set Cmnt = Nothing: Set Bunka = Nothing: Set ARE = Nothing: Set Zmena = Nothing
End Sub
a druhý:
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPathJpg As String, Zmena As Range, Bunka As Range, H(), Pocet As Long
strPathJpg = "C:\"
Set Zmena = Intersect(Range("A:A"), Target)
If Not Zmena Is Nothing Then
Application.EnableEvents = False
With Zmena
Pocet = .Cells.Count
ReDim H(1 To Pocet, 1 To 1)
If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1
For Each Bunka In .Cells
With Bunka.Hyperlinks
If IsEmpty(H(Pocet, 1)) Then .Delete Else .Add Anchor:=Bunka, Address:=strPathJpg & H(Pocet, 1) & ".jpg"
End With
Pocet = Pocet + 1
Next Bunka
End With
Set Bunka = Nothing: Set Zmena = Nothing: Erase H
Application.EnableEvents = True
End If
End Sub
Děkuji mnohokrát.
Jsem prostě LAMA.