PC-HELP.CZ

Dobrý den, potřeboval bych, upravit kód na vkládaní obrázku do komentáře.
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.

Napr. takto.

elninoslov píše:Napr. takto.

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("Q2:Q1000"))
  If Zmena Is Nothing Then Exit Sub
  ' disk a cesta, pripona
  DiskPath = "Z:\\"
  Extsn = ".jpg"
 
  Application.ScreenUpdating = False
  ' Smazat pripadne stare komentare
  Zmena.Offset(, -12).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(, -12).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

Říkám to už po druhé, tento Pán má zlaté ručičky.
Funguje skvěle, díky moc skvělá práce.