Komentáře v excelu do buněk Vyřešeno

[Puzzlehead]

Zravím,
chtěl bych dostat komentáře, které jsou uvedeny u buněk do samostatných buněk. Přesný opak toho co bylo uděláno v tomto tématu

http://www.pc-help.cz/viewtopic.php?f=35&t=47005&p=322568&hilit=koment%C3%A1%C5%99e#p322568

Díky

[Reklama]

[Teedok]

jenom pro uřesnění: ty máš nějaké komentáře a obsah těch komentářů chceš dostat jako text do buněk?

[Puzzlehead]

Ano přesně tak.

[Teedok]

nevim jestli to chceš dělat najednou, tak jak to bylo v tebou zmiňovaném topicu, ale když klikneš pravým tlačítkem myši na komentář a dáš upravit komentář, obsah si můžeš zkopírovat a vložit do buňky. Ovšem jestli máš třeba 50 komentářů tak to nevim jak na to.

[Puzzlehead]

Právě to je ten problém. Spousta komentářů ve spoustě sešitů na spoustě listů. Ručně je to na sebevraždu :-). Dřív si totiž někdo myslel, že když to bude psát do komentářu bude to mít přehlednější

[Teedok]

tak ono to na jednu stranu přehlednější je:)

[Puzzlehead]

Jo pokud, chceš k nějaké buňce dát doplňující informaci, ale vést celý seznam a veškeré potřebné informace v poznámkách, které cheš dále spracovávát a vyhodnocovat je potom nemyslitelné.

[navstevnik]

Pozadovane resi v nejjednodussi podobe pro jednorazove pouziti nasledujici procedura (v editoru VBA - Alt+F11 - vlozit do standardniho modulu, nutno si upravit rozsah bunek s komentari, adresu bunky pro ulozeni komentaru a pripadne aktivovat radek kodu pro smazani zdrojovych komentaru):

Kód: Vybrat vše

Option Explicit

Sub ZKomentareDoBunky1()
  Dim c As Range, SBlok As Range, TCll As Range, Ofsr As Integer
  ' nutno upravit dle potreby:
  Set SBlok = Worksheets("list3").Range("b2:b10")
  Set TCll = Worksheets("list3").Range("k1")
  '
  Ofsr = 0
  For Each c In SBlok.Cells
    On Error Resume Next
    With TCll
    .Offset(Ofsr, 1).Value = c.Comment.Text
      If err.Number = 0 Then
        .Offset(Ofsr, 0).Value = c.Address(0, 0)
        '  odstraneni zdrojoveho komentare, aktivovat dle potreby
        '    c.ClearComments
        Ofsr = Ofsr + 1
      End If
    End With
    On Error GoTo 0
  Next c
  Set SBlok = Nothing
  Set TCll = Nothing
End Sub


[Poki]

Jde to udelat touto procedurou:

Kód: Vybrat vše

Public Sub commentsTocells()

  For i = 1 To 14 'rozsah radku (1-14)
    For j = 1 To 16 'rozsah sloupcu (A - P)
      If Not Cells(i, j).comment Is Nothing Then
        Cells(i, j) = Cells(i, j).comment.Text
      End If
    Next
  Next

End Sub

[Puzzlehead]

To Navstevnik:
O.K., toto funguje. Ještě jeden dotaz. Lze provést výpis do řádku s tím, že nepotřebuji mít komentář identifikovaný buňkou, ve které byl uložen?

Díky

[Puzzlehead]

To Poki: Díky, po menší upravě je tohle přesně co potřebuji. Změnil jsem

Cells(i-1, j) = Cells(i, j).comment.Text

a tím jsem to dostal na řádek nad.

Super, díky