MyTetra Share
Делитесь знаниями!
Как получить текст примечания в ячейку?
Время создания: 16.03.2019 23:43
Текстовые метки: примечания
Раздел: !Закладки - VBA - Excel
Запись: xintrea/mytetra_db_adgaver_new/master/base/1514992275wo1dnrs6ek/text.html на raw.githubusercontent.com

Как получить текст примечания в ячейку?

Есть таблица по платежам. В ячейках определенных столбцов в примечаниях(вкладка Рецензирование -Создать примечание) записывается дополнительная информация по платежу. Например, номер договора, на основании которого был произведен платеж. И теперь необходимо отобрать записи только по определенным договорам. Ячеек несколько сотен, просматривать и выписывать договора из комментариев вручную похоже на одну из разновидностей древнеримских пыток. Однако при помощи VBA сделать это совсем просто.

Создадим простую функцию пользователя:

Function Get_Text_from_Comment(rCell As Range) On Error Resume Next Get_Text_from_Comment = rCell.Comment.Text End Function


1

2

3

4

Function Get_Text_from_Comment(rCell As Range)

    On Error Resume Next

    Get_Text_from_Comment = rCell.Comment.Text

End Function

Синтаксис вызова функции с листа Excel:
=Get_Text_from_Comment(A1)
A1 - ячейка с примечанием, текст которого необходимо получить. Если комментарий в ячейке отсутствует, то функция вернет пусто.
Чтобы правильно использовать приведенный код, необходимо сначала ознакомиться со статьей Что такое функция пользователя(UDF)?. Вкратце: необходимо скопировать текст кода выше, перейти в редактор VBA(Alt+F11) -создать стандартный модуль(Insert -Module) и в него вставить скопированный текст. После чего функцию можно будет вызвать из Диспетчера функций, отыскав её в категории Определенные пользователем (User Defined Functions).


Текст из примечания без автора примечания
Слегка доработанная функция, в которой можно отсечь имя пользователя, создавшего комментарий:

Function Get_Text_from_Comment(rCell As Range) As String Dim sTxt As String On Error Resume Next sTxt = rCell.Comment.Text Get_Text_from_Comment = Mid(sTxt, InStr(sTxt, ":") + 2) End Function


1

2

3

4

5

6

Function Get_Text_from_Comment(rCell As Range) As String

    Dim sTxt As String

    On Error Resume Next

    sTxt = rCell.Comment.Text

    Get_Text_from_Comment = Mid(sTxt, InStr(sTxt, ":") + 2)

End Function

Синтаксис вызова с листа Excel такой же, как и в функции выше. Просто указываете внутри функции ссылку на ячейку.
=Get_Text_from_Comment(A1)


Код записи текста примечаний в выделенных ячейках
Если текст из примечаний необходимо записать в те же ячейки одним махом и удалить после этого все примечания, можно использовать следующий код:

'--------------------------------------------------------------------------------------- ' Author : The_Prist(Щербаков Дмитрий) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' http://www.excel-vba.ru ' Purpose: Процедура записи текста из примечаний в ячейки выделенного диапазона '--------------------------------------------------------------------------------------- Sub CommentsToCell() Dim sTxt As String, res As String, rc As Range, rr As Range Dim IsDelAuthor As Boolean, IsDelComment As Boolean, IsReplaceCellVal As Boolean 'запрашиваем параметры If MsgBox("Оставлять автора комментария?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbNo Then IsDelAuthor = True End If If MsgBox("Заменять значение, если в ячейке с комментариями уже есть текст?" & vbNewLine & _ "ДА(Yes) - значения ячеек будут заменены текстом комментариев" & vbNewLine & _ "НЕТ(No) - к имеющимся значениям будет добавлен текст комментария", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes Then IsReplaceCellVal = True End If If MsgBox("Удалять комментарии после обработки?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes Then IsDelComment = True End If On Error Resume Next 'получаем в выделенном диапазоне только ячейки с комментариями Set rr = Selection.SpecialCells(xlCellTypeComments) If rr Is Nothing Then MsgBox "В выделенном диапазоне нет ячеек с комментариями", vbCritical, "www.excel-vba.ru" Exit Sub End If On Error GoTo 0 Application.ScreenUpdating = False 'цикл по всем ячейкам с комментариями For Each rc In rr.Cells sTxt = rc.Comment.Text If IsDelAuthor Then res = Mid(sTxt, InStr(sTxt, ":") + 2) Else res = sTxt End If If IsReplaceCellVal Then rc.Value = res Else rc.Value = rc.Value & Chr(10) & res End If Next If IsDelComment Then rr.ClearComments End If Application.ScreenUpdating = True MsgBox "Комментарии записаны", vbCritical, "www.excel-vba.ru" End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

'---------------------------------------------------------------------------------------

' Author : The_Prist(Щербаков Дмитрий)

'          Профессиональная разработка приложений для MS Office любой сложности

'          Проведение тренингов по MS Excel

'          http://www.excel-vba.ru

' Purpose: Процедура записи текста из примечаний в ячейки выделенного диапазона

'---------------------------------------------------------------------------------------

Sub CommentsToCell()

    Dim sTxt As String, res As String, rc As Range, rr As Range

    Dim IsDelAuthor As Boolean, IsDelComment As Boolean, IsReplaceCellVal As Boolean

    'запрашиваем параметры

    If MsgBox("Оставлять автора комментария?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbNo Then

        IsDelAuthor = True

    End If

    If MsgBox("Заменять значение, если в ячейке с комментариями уже есть текст?" & vbNewLine & _

              "ДА(Yes) - значения ячеек будут заменены текстом комментариев" & vbNewLine & _

              "НЕТ(No) - к имеющимся значениям будет добавлен текст комментария", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes Then

        IsReplaceCellVal = True

    End If

    If MsgBox("Удалять комментарии после обработки?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes Then

        IsDelComment = True

    End If

    On Error Resume Next

    'получаем в выделенном диапазоне только ячейки с комментариями

    Set rr = Selection.SpecialCells(xlCellTypeComments)

    If rr Is Nothing Then

        MsgBox "В выделенном диапазоне нет ячеек с комментариями", vbCritical, "www.excel-vba.ru"

        Exit Sub

    End If

    On Error GoTo 0

    Application.ScreenUpdating = False

    'цикл по всем ячейкам с комментариями

    For Each rc In rr.Cells

        sTxt = rc.Comment.Text

        If IsDelAuthor Then

            res = Mid(sTxt, InStr(sTxt, ":") + 2)

        Else

            res = sTxt

        End If

        If IsReplaceCellVal Then

            rc.Value = res

        Else

            rc.Value = rc.Value & Chr(10) & res

        End If

    Next

    If IsDelComment Then

        rr.ClearComments

    End If

    Application.ScreenUpdating = True

    MsgBox "Комментарии записаны", vbCritical, "www.excel-vba.ru"

End Sub


Код необходимо так же скопировать и вставить в стандартный модуль(Переходим в редактор VBA(Alt+F11) -Insert -Module).
Выделить диапазон ячеек, комментарии из которых необходимо перенести, нажать Alt+F8 и выбрать код CommentsToCell. Код содержит несколько параметров:

  • Сначала необходимо будет выбрать оставить ли автора комментария при считывании текста из комментария. Если выбрать да - весь текст примечания будет перенесен как есть. Если выбрать Нет - то из комментария будет отсечена первая строка до символа двоеточия(:). Именно так по умолчанию Excel обозначает автора.
    Этот параметр нужен, если в ячейках нет автора.
  • Далее будет запрос: оставить значение в ячейках и дописать к ним текст примечания или заменить существующие значения в ячейке на текст комментария. Может пригодиться, если в ячейках записаны суммы платежей и надо добавить к ним из комментария номер договора, не убирая сами суммы.
  • И последний запрос будет: удалять комментарии из ячеек после записи текста из них в ячейки или оставить. Если выбрать да - то после обработки всех выделенных ячеек комментарии будут удалены. Это может пригодиться, если комментариев много. Их удаление может существенно облегчить файл.
Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования