Uprava procedury - dva kody VBA Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 1
Level 1
Příspěvky: 99
Registrován: únor 12
Pohlaví: Nespecifikováno

Uprava procedury - dva kody VBA

Příspěvekod luko02420 » 16 dub 2018 07:52

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. :oops:



Reklama
Uživatelský avatar
elninoslov
Level 1.5
Level 1.5
Příspěvky: 140
Registrován: červen 13
Pohlaví: Muž

Re: Uprava procedury - dva kody VBA

Příspěvekod elninoslov » 16 dub 2018 09:20

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
Level 1
Level 1
Příspěvky: 99
Registrován: únor 12
Pohlaví: Nespecifikováno

Re: Uprava procedury - dva kody VBA

Příspěvekod luko02420 » 16 dub 2018 09:47

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.

Uživatelský avatar
elninoslov
Level 1.5
Level 1.5
Příspěvky: 140
Registrován: červen 13
Pohlaví: Muž

Re: Uprava procedury - dva kody VBA

Příspěvekod elninoslov » 17 dub 2018 00:37

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
Nemáte oprávnění prohlížet přiložené soubory.

luko02420
Level 1
Level 1
Příspěvky: 99
Registrován: únor 12
Pohlaví: Nespecifikováno

Re: Uprava procedury - dva kody VBA  Vyřešeno

Příspěvekod luko02420 » 17 dub 2018 07:13

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


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • zrýchlenie procedúry
    od tsibee » 12 čer 2018 09:02 » v Kancelářské balíky
    2
    289
    od tsibee
    12 čer 2018 13:07
  • Úprava nootebooku
    od SALi » 02 říj 2017 12:00 » v Taktování a další úpravy PC
    3
    387
    od SALi
    02 říj 2017 12:18
  • Dva monitory
    od nakatomi » 09 led 2018 20:47 » v Vše ostatní (hw)
    2
    271
    od xbs
    09 led 2018 20:53
  • dva monitory ?
    od sendyys » 17 kvě 2018 19:15 » v Vše ostatní (hw)
    5
    338
    od xbs
    17 kvě 2018 20:52
  • Excel- VBA
    od Nelouš » 22 bře 2018 00:14 » v Programování a tvorba webu
    4
    599
    od Nelouš
    22 bře 2018 17:43

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot], Majestic-12 [Bot] a 2 hosti