Uprava procedury - dva kody VBA

[luko02420]

Dobrý den, ještě otravuji jednou narazil jsem ještě na problem, že nedokažu napasovat dva kody do jednoho listu.
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.

[elninoslov]

Myslel som si, že s tým prídete :)
Oba kódy teda majú reagovať na zmenu v stĺpci A?
Prečo prvý iba v oblasti A1:A100 a druhý v celom A:A?
Nemajú tie stĺpce náhodou hlavičku? Ak áno treba vynechať z kontroly 1. riadok.
Oba budú čerpať obrázky z rovnakého adresára?
Oba budú čerpať obrázky s rovnakým menom?
...

[luko02420]

Dobrý den, je vidět, že mě máte přečteného .
Oba dva budou reagovat na na oblast A2:A1000. V žádosti jsem to přehlédl.
Obrázky do komentáře půjdou z jedné složky a hypertext odkaz z jiné složky z důvodu velikosti souborů.
Ano budou mít oba shodné názvy.
Děkuji.

[elninoslov]

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, Bunka As Range, H(), Pocet As Long, strPathJpg As String
 
  Set Zmena = Intersect(Target, Range("A2:A1000"))  ' identifikace zmeny v oblasti
  If Zmena Is Nothing Then Exit Sub                 ' je zmena v pozadovane oblasti bunek
  
  DiskPath = "C:\Users\"                            ' disk a cesta k souborum obrazku v komentarich
  strPathJpg = "C:\"                                ' disk a cesta k souborum pro HL, pripona
  Extsn = ".jpg"                                    ' pripona
 
  Application.ScreenUpdating = False
  Zmena.Offset(, 2).ClearComments                   ' Smazat pripadne stare komentare
 
  With Zmena
    Pocet = .Cells.Count                            ' pocet bunek v oblasti
    ReDim H(1 To Pocet, 1 To 1)
    If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1 ' nacist data zmeny pro celou oblast
     
    For Each Bunka In .Cells                        ' projit vsechny bunky v oblasti
      If Not IsEmpty(H(Pocet, 1)) Then              ' vlozi komentar a HL kdyz neni datova bunka prazdna
        
        With Bunka.Offset(, 2).AddComment           ' vlozi komentar, kde 2 znamena ze se komentar vlozi o 2 bunky do prava
          On Error Resume Next
          .Shape.Fill.UserPicture DiskPath & H(Pocet, 1) & Extsn    'vlozi obrazek podle nazvu v bunce a formatuje komentar
          If Err.Number <> 0 Then .Text Text:="Obrazek nebyl nalezen" ' osetreni chyby pri odkazu na obrazek
          On Error GoTo 0
          .Shape.Height = 450                       ' nastavit vysku komentare
          .Shape.Width = 650                        ' nastavit sirku komentare
          .Visible = False                          ' zobrazeni komentare pouze pri najeti kurzoru na bunku = False nebo trvale = True
        End With
        
        Bunka.Hyperlinks.Add Anchor:=Bunka, Address:=strPathJpg & H(Pocet, 1) & Extsn  ' zmen HL v bunce
      End If
       
      Pocet = Pocet + 1
    Next Bunka
  End With
 
  Application.ScreenUpdating = True
  Set Cmnt = Nothing: Set Bunka = Nothing: Set Zmena = Nothing: Erase H
End Sub

[luko02420]

Děkuji, funguje skvěle, přesně jak má.
Zamykám.