Více buňek do jednoho komentáře Vyřešeno

[Toomicek]

Ahoj,

mám další problém s VBA. Potřeboval bych text z vícero buňek (3-5) vložit do komentáře v jiném sešitu/listu. Přikládám menší vzor, jak by to mělo vypadat.

Díky moc za pomoc

Tom

[Reklama]

[cmuch]

Tady jsem sesmolil jedno co vloží komentář ze tří buněk do jedné a ztuční vybraný text.
Třeba poslouží jako vodítko.

Kód: Vybrat vše

Sub AddMultiCommentActiveCell()
  'Posted by Cmuch
  Dim Cmt As Comment, strCmt As String
  Dim strCmt1a As String, strCmt1b As String
  Dim strCmt2a As String, strCmt2b As String
  Dim strCmt3a As String, strCmt3b As String
 
  On Error Resume Next
  With ActiveCell
    .Comment.Delete
    strCmt1a = "Tomáš" & Chr(10)
    strCmt1b = Range("G14").Value & Chr(10)
    strCmt2a = "Petr" & Chr(10)
    strCmt2b = Range("H14").Value & Chr(10)
    strCmt3a = "Ondra" & Chr(10)
    strCmt3b = Range("I14").Value
     
    strCmt = strCmt1a & strCmt1b & strCmt2a & strCmt2b & strCmt3a & strCmt3b
     
    Set Cmt = .AddComment(strCmt)
   
    With Cmt.Shape.TextFrame
      .Characters.Font.Bold = False
      .Characters(1, Len(strCmt1a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b), Len(strCmt2a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b) + Len(strCmt2a) + Len(strCmt2b), Len(strCmt3a)).Font.Bold = True
      .AutoSize = True
    End With 'Cmt.Shape.TextFrame
  End With 'ActiveCell
End Sub

[Toomicek]

Úžasný díky, ale měl bych k tomu další už trochu koplexnější prosbu, pokud to je vůbec možné udělat.

V tabluce v příloze bych potřeboval, když na jednom listu/sešitu se napíše k zakázce (S1401) více komentářů od "Tomáše" a v dalším listu od "Petra" atd.,tak aby makro umělo poznat dle textu v buňce u které chci komentář (V buňce bude S1401) co bude v komentáři, tudíž veškeré údaje o zakázce S1401. Tudíž aby se komentáře vytvářeli automaticky. V příloze mám i automatický výběr bodů ze seznamu (kam bych odkazoval, pokud bych nepoužil makro) pokud by to mohlo nějak pomoci :)

kdyby jste potřebovali upřesnit můj nesrozumitelný dotaz pište i do zpráv :)

Díky moc.,

[guest]

"Díky, akorát bych potřeboval ještě a ještě a mám spousty dalších nápadů " No ještě že má cmuch tolik komplexního času Apropo, reagovat a psát Vám soukromé zprávy se míjí účinkem. Takže si to vy dva užijte

[cmuch]

"Díky, akorát bych potřeboval ještě a ještě a mám spousty dalších nápadů "

Jo to znám z práce až moc dobře

No ještě že má cmuch tolik komplexního času

No moc ho nemá.

... pište i do zpráv :)

Radší přispívám do tématu, alespoň je vidět jak se téma vyvíjí.

Jinak já si to užívám

Tady je upravené makro

Kód: Vybrat vše

Sub AddMultiCommentActiveCell()
  'Posted by Cmuch
  Dim Cmt As Comment, strCmt As String
  Dim strCmt1a As String, strCmt1b As String
  Dim strCmt2a As String, strCmt2b As String
  Dim strCmt3a As String, strCmt3b As String
  Dim i As Byte, MoreCmt As Boolean
 
  On Error Resume Next
  With ActiveCell
    .Comment.Delete
   
    strCmt1a = "Tomáš" & Chr(10)
   
    MoreCmt = False
    For i = 3 To 10
      If Not Cells(i, "I") = "" Then
        If MoreCmt = True Then
          strCmt1b = strCmt1b & Cells(i, "I").Value & Chr(10)
        Else
          strCmt1b = Cells(i, "I").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i
   
    strCmt2a = "Petr" & Chr(10)
   
    MoreCmt = False
    For i = 3 To 10
      If Not Cells(i, "J") = "" Then
        If MoreCmt = True Then
          strCmt2b = strCmt2b & Cells(i, "J").Value & Chr(10)
        Else
          strCmt2b = Cells(i, "J").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i
   
    strCmt3a = "Ondra" & Chr(10)
   
    MoreCmt = False
    For i = 3 To 10
      If Not Cells(i, "K") = "" Then
        If MoreCmt = True Then
          strCmt3b = strCmt3b & Cells(i, "K").Value & Chr(10)
        Else
          strCmt3b = Cells(i, "K").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i
     
    strCmt = strCmt1a & strCmt1b & strCmt2a & strCmt2b & strCmt3a & strCmt3b
     
    Set Cmt = .AddComment(strCmt)
   
    With Cmt.Shape.TextFrame
      .Characters.Font.Bold = False
      .Characters(1, Len(strCmt1a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b), Len(strCmt2a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b) + Len(strCmt2a) + Len(strCmt2b), Len(strCmt3a)).Font.Bold = True
      .AutoSize = True
    End With 'Cmt.Shape.TextFrame
  End With 'ActiveCell
End Sub

[Toomicek]

"Díky, akorát bych potřeboval ještě a ještě a mám spousty dalších nápadů " No ještě že má cmuch tolik komplexního času Apropo, reagovat a psát Vám soukromé zprávy se míjí účinkem. Takže si to vy dva užijte

Pochopil jsem Jinak já si to tady taky nevymýšlím, jen jsem jednou ukázal že umím makra a hned po mě chtějí kouzla :(

Tady je upravené makro

Tak jsem to vyzkoušel, je to dost vymakaný, ale šlo by to zautomatizovat nějak? Třeba, pokud by v tabulce byl příznak S1401, tak by se automaticky vyhledali komentáře z tabulky od "Petra" a vložil se k buňce?

Opět přikládám vzor pokud to pomůže.

[cmuch]

Ty komentáře se budou načítat do buněk kde?
Na tom samém listě?
Z toho příkladu to není zřejmé. Někde se musí zadat do jakých buněk se smí zapsat komentář.

Komentáře se mohou načíst do buňky samy buď na nějaké tlačítko nebo událost ( výběr buňky nebo zápis do buňky),

[Toomicek]

Myslím to tak, že pokud se zapíše do buňky kam má psát "Tomáš" aktualizuje se komentář v buňce se zakázkou. A takhle by se měli vkládat komentáře do jedné buňky po změně v nich. Tam je nějaký příkaz worksheet_change s tim bych to chtěl spojit. Komentáře budou vepisovány do zdrojových buněk ručně a z jiných listů ve stejném souboru (upustil jsem od více sešitů, místo toho jsem udělal userform, a to je hodí na zvláštní list kam můžou vepisovat)

díky :)

[cmuch]

Vlož do modulu listu kde jsou komentáře.
Změň list a oblasti kde se budou zobrazovat komenáře,
popřípadě co se bude zobrazovat když k člověku nebudou komentáře (teď ---)

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
'Posted by Cmuch
 Dim Cmt As Comment, strCmt As String
 Dim strCmt1a As String, strCmt1b As String
 Dim strCmt2a As String, strCmt2b As String
 Dim strCmt3a As String, strCmt3b As String
 Dim i As Integer, MoreCmt As Boolean
 Dim bigRange As Range
 
 On Error Resume Next
 With Sheets("List1") 'list kam se budou zapisovat komentare
   ' lze napsat az 30 oblasti
   Set bigRange = Application.Union(.Range("J7:J9"), .Range("J10"))
 End With
 
 For Each Rng In bigRange
  strCmt1b = "---" & Chr(10): strCmt2b = "---" & Chr(10): strCmt3b = "---" & Chr(10)
  If Not Rng = "" Then
  With Rng
   .Comment.Delete
   
   With ActiveSheet 'Sheets("Komentare") 'list odkud se berou komentare

    strCmt1a = .Cells(1, "B") & Chr(10)

    MoreCmt = False
    For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
      If Not .Cells(i, "B") = "" And .Cells(i, "B").Offset(0, -1) = Rng Then
        If MoreCmt = True Then
          strCmt1b = strCmt1b & .Cells(i, "B").Value & Chr(10)
        Else
          strCmt1b = .Cells(i, "B").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i
   
    strCmt2a = .Cells(1, "E") & Chr(10)
   
    MoreCmt = False
    For i = 2 To .Cells(.Rows.Count, "E").End(xlUp).Row
      If Not .Cells(i, "E") = "" And .Cells(i, "E").Offset(0, -1) = Rng Then
        If MoreCmt = True Then
          strCmt2b = strCmt2b & .Cells(i, "E").Value & Chr(10)
        Else
          strCmt2b = .Cells(i, "E").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i

    strCmt3a = .Cells(1, "H") & Chr(10)

    MoreCmt = False
    For i = 2 To .Cells(.Rows.Count, "H").End(xlUp).Row
      If Not .Cells(i, "H") = "" And .Cells(i, "H").Offset(0, -1) = Rng Then
        If MoreCmt = True Then
          strCmt3b = strCmt3b & .Cells(i, "H").Value & Chr(10)
        Else
          strCmt3b = .Cells(i, "H").Value & Chr(10)
          MoreCmt = True
        End If
      End If
    Next i
     
   End With 'Activesheets 'sheets("Komentare")
     
   strCmt = strCmt1a & strCmt1b & strCmt2a & strCmt2b & strCmt3a & strCmt3b
     
   Set Cmt = .AddComment(strCmt)
   
   With Cmt.Shape.TextFrame
      .Characters.Font.Bold = False
      .Characters(1, Len(strCmt1a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b), Len(strCmt2a)).Font.Bold = True
      .Characters(Len(strCmt1a) + Len(strCmt1b) + Len(strCmt2a) + Len(strCmt2b), Len(strCmt3a)).Font.Bold = True
      .AutoSize = True
   End With 'Cmt.Shape.TextFrame
  End With 'Rng
  End If
 Next Rng
End Sub



[Toomicek]

Díky moc za odpověď. Našel jsem funkční makro přes gúgleho a hrál si s nim, takže jsem podle něj upravil i postup jakým to dělám. Při tomhle makru co uvádíš mi spadne excel :( :( nevím proč. Ale to už nemusíme řešit to co jsem našel funguje v pořádku.

Jen bych potřeboval aby makro bylo spuštěno při změně v listu, jenže já nevkládám data ručně, odkazy jsou vkládány z jiných listů.

Kód: Vybrat vše

=Přehled!B6

Nebo za určitých podmínek.

Kód: Vybrat vše

=KDYŽ(Rozpočet!J5="";"";Rozpočet!J5)

Ještě jsem se pokoušel implementovat zápis datumu vedle do buňky ale taky jsem ztroskotal na aktivaci pomocí ručního vkládání :(

POZN: worksheet_change bych asi zaměnil za calculate, ale netuším jak :( :(

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Changed As Range, c As Range
  Dim s As String, cmt As String, sBold As String
  Dim aTLC As Variant, aData As Variant, aBold As Variant
  Dim i As Long, Tbl As Long
  Dim bStarted As Boolean
 
  Const TopLeftCells As String = "A1 D1 G1 J1" '<- Top left cell of each table
  Const CommentCells As String = "N5:N200"  '<- Range to add/delete/edit comments
 
  Set Changed = Range(CommentCells)
  If Not Changed Is Nothing Then
    aTLC = Split(TopLeftCells)
    For Each c In Changed
      c.ClearComments
      s = c.Text
      cmt = ""
      sBold = ""
      If Len(s) > 0 Then
        For Tbl = 0 To UBound(aTLC)
          aData = Range(aTLC(Tbl)).CurrentRegion.Value
          bStarted = False
          For i = 2 To UBound(aData, 1)
            If aData(i, 1) = s Then
              If Not bStarted Then
                sBold = sBold & "," & Len(cmt) + 1 & "," & Len(aData(1, 2))
                bStarted = True
                cmt = cmt & vbLf & aData(1, 2)
              End If
              cmt = cmt & vbLf & aData(i, 2)
            End If
          Next i
        Next Tbl
        If Len(cmt) > 0 Then
          c.AddComment.Text Text:=Mid(cmt, 2)
          aBold = Split(sBold, ",")
          For i = 1 To UBound(aBold) Step 2
            c.Comment.Shape.TextFrame.Characters(aBold(i), aBold(i + 1)).Font.Bold = True
          Next i
          c.Comment.Shape.TextFrame.AutoSize = True
        End If
      End If
    Next c
  End If
 
'Vložení datumu při změně v buňce
If Not Intersect(Target, Range("N:N")) Is Nothing Then
   Range("O" & Target.Row).Value = Now
End If
End Sub


Děkuji za tvůj čas

Tom

[cmuch]

Měl jsem tam překlep, již opraveno.

Jinak Calkulate je

Kód: Vybrat vše

Private Sub Worksheet_Calculate()

Ale tady spíš by bylo lepší aby se to makro provedlo při aktivaci listu

Kód: Vybrat vše

Private Sub Worksheet_Activate()


Nelze používat Target !!

Jen bych potřeboval aby makro bylo spuštěno při změně v listu, jenže já nevkládám data ručně, odkazy jsou vkládány z jiných listů.

Toto je zas něco jiného než bylo psáno

.... a to je hodí na zvláštní list kam můžou vepisovat

Ten datum je tam k čemu?
Má být vedle buňky kam někdo zapsal komentář nebo jak?

[Toomicek]

Datum je jen pro kontrolu (management chce vědět) kdy se měnila jaká zakázka naposledy. To co mám ty změny s vkládáním to nemusíš řešit jelikož já makro chci používat jen na jedno listu s vloženými daty, což už funguje.

No a právě řeším ten problém jak aktivovat makro když např.: z Buňky A1 na Listu1 mám odkaz do jiného listu ("Přehled")kde chci mít makro. Pokud ručně změním A1 na Přehledu makro se zaktivuje a komentáře se vytvoří. Jenže když změním A1 na listu1 nic se v přehledu nestane i když se hodnota změnila (přes ten odkaz).

Nikde jsem to nedokázal vygooglit, tak zda-li tě něco nenapadne :(

Díky