Obrázek v komentáři-úprava kódu

[luko02420]

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.

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

[elninoslov]

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

[luko02420]

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.