Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

Автор Тема: В примечании к ячейке расшифровываем ее содержимое.  (Прочитано 2301 раз)

0 Пользователей и 1 Гость просматривают эту тему.

GWolf

  • Старожил
  • ****
  • Уважение: +50/-0
  • Оффлайн Оффлайн
  • Сообщений: 943

Итак задача: в ячейке вводим значения в виде:

   =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

Собрать и посмотреть чего в примечания навводили можно так: http://forum.msexcel.ru/microsoft_excel/primechaniya-t2520.0.html
« Последнее редактирование: 27.11.2009, 17:37:28 от GWolf »
Записан
Путей к вершине - множество. Этот один из многих!
 



Темы без ответов

24.01.2020 14:03 На диаграмме Ганта несоответствие оси Y 1131
09.08.2019 14:09 Макрос для заполнения таблиц через форму 2879
18.07.2019 16:02 Рассылка почты из Excel при помощи почтовой программы TheBAT! 2497
09.07.2019 20:39 Кредит с уменьшением периода выплат 2593
28.05.2019 21:09 Сделать несколько скриптов для рабочей таблицы 3305
05.03.2019 17:00 Последовательный вывод таблиц Excel в один документ Word без шаблона 3199
05.03.2019 09:29 Нежелательные изменение размеров колонтитула при редактировании 2959
07.02.2019 01:36 Как удалить дубликаты из выпадающего связанного списка? 3121
20.01.2019 12:38 Все варианты частичного суммирования 3280
13.01.2019 12:24 Заполнение диапазона числами - в виде кластеров 2628





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.151 секунд. Запросов: 88.