Итак задача: в ячейке вводим значения в виде:
=6325+3256+321 и т.д.
нужно в примечании к этой ячейке, по мере ввода значений, накапливать информацию о них (значениях):
6 325,00 = 27 11 2009 (125);
3 256,00 = 27 11 2009 (400);
321,00 = 27 11 2009 (410);
где: 6 325,00 - выданная сумма;
27 11 2009 - дата выдачи;
125 - номер заявки (записи) по Книге выдачи;
Дополнительные условия:
запуск макроса должен осуществлятся по комбинации клавишь (Ctrl + q);
размер примечания должен изменятся в зависимости от количества и длинны строк, накапливаемой информации.
Решение: - приведенный ниже код записываем в стандартный модуль книги Excel, в любом листе этой книги выбираем ячейку, нажимаем Ctrl + q и отвечаем на запросы машины.
Код:
Function gummCell(zapis As String)
'"Резиновое" примечание
Dim i As Integer, pozisRzdl As Integer, nomEndSimv As Integer, kvoSlov As Integer, _
lenSlovo As Integer, lenOldSlovo As Integer
Dim slovo As String, zp1 As String
Dim arrZnac(0 To 2) As String
zp1 = zapis
i = 0
pozisRzdl = 0
nomEndSimv = 0
nomEndSimv = Len(zp1)
kvoSlov = 1
lenSlovo = 0
lenOldSlovo = 0
For i = 1 To nomEndSimv
pozisRzdl = InStr(1, zp1, Chr(10), vbTextCompare)
If pozisRzdl > 0 Then
slovo = Mid(zp1, 1, pozisRzdl - 1)
zp1 = Mid(zp1, pozisRzdl + 1)
kvoSlov = kvoSlov + 1
pozisRzdl = 0
Else
slovo = Mid(zp1, 1)
End If
lenSlovo = Len(slovo)
If lenSlovo > lenOldSlovo Then
lenOldSlovo = lenSlovo
lenSlovo = 0
End If
Next i
arrZnac(0) = zapis
arrZnac(1) = CStr(lenOldSlovo * 4.57)
arrZnac(2) = CStr((kvoSlov + 1) * 11.1)
gummCell = arrZnac
Erase arrZnac
End Function
Sub Primecanie()
'
' Расшифровка суммы в примечании Макрос
' Макрос записан 08.06.2009 (Gregory)
'
' Сочетание клавиш: Ctrl+q
'
Dim txtCom As String, stroka As String
Dim ravn As Integer, plus As Integer
Dim arrGum() As String
znPlus = 0
znPlus = Format(InputBox("- введите значение:", "Выданная сумма:", 0), "#,##0.00")
If znPlus <> 0 Then
ravn = 0
plus = 0
With ActiveCell
znacTXT = .FormulaR1C1
If znacTXT = "" And Not .Comment Is Nothing Then
.ClearComments
End If
plus = InStrRev(znacTXT, "+", -1, vbTextCompare)
ravn = InStr(1, znacTXT, "=", vbTextCompare)
datS = InputBox("- в формате (гггг мм дд):", "Дата выдачи:", Format(Date, "yyyy mm dd"))
nmZajavki = Format(InputBox("- №:", "Номер заявки (по книге выдачи):", ""), " (000)")
If ravn > 0 And plus = 0 Or plus > 0 Then
txtCom = ""
If Not .Comment Is Nothing Then
txtCom = .Comment.Text
Else
.AddComment
.Comment.Visible = False
End If
stroka = txtCom & znPlus & " = " & Format(datS, "dd mm yyyy") & nmZajavki & ";" & Chr(10)
.FormulaR1C1 = znacTXT & "+" & CDbl(znPlus)
ElseIf ravn = 0 And plus = 0 Then
txtCom = ""
.AddComment
.Comment.Visible = False
stroka = znPlus & " = " & Format(datS, "dd mm yyyy") & nmZajavki & ";" & Chr(10)
.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
.FormulaR1C1 = "=" & CDbl(znPlus)
End If
arrGum = gummCell(stroka) '- делаем "резиновым" примечание
.Comment.Text Text:=arrGum(0)
stroka = ""
With .Comment.Shape
.Width = CDbl(arrGum(1))
.Height = CDbl(arrGum(2))
End With
Erase arrGum
End With
End If
End Sub
Собрать и посмотреть чего в примечания навводили можно так: https://forum.msexcel.ru/microsoft_excel/primechaniya-t2520.0.html