Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Заполнение реестра адресатов отправленных писем с других листов
 
#1
25.08.2022 16:44:15
Здравствуйте! в экселе не особый эксперт, но может с чьей-либо подсказкой и смогла бы разобраться.
Есть документ с адресами и страницы с конвертами для печати определенного размера. Нужно сделать реестр распечатанных писем. Сегодня я отправляла 2 письма и печатала 2 конверта. Нужно что бы адресаты распечатанных вбивались в реестр в колонку "Кому".  
Изменено: Юрий М - 25.08.2022 17:04:51
 
 
 
#2
25.08.2022 16:57:34
Код
Sub FillRegistry()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.Item(Sheets("Маленький").Range("D1").Value) = 0
    dic.Item(Sheets("Длинный").Range("D1").Value) = 0
    dic.Item(Sheets("Большой").Range("E2").Value) = 0
    
    If dic.Exists(Empty) Then dic.Remove Empty
    If dic.Count Then
        With Sheets("РЕЕСТР")
            With .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(dic.Count)
                .Columns(1).Value = Date
                .Columns(2).Value = Application.Transpose(dic.Keys())
            End With
        End With
    End If
End Sub

Как вставить готовый макрос в рабочую книгу (office-guru.ru)
Вариант названия темы
Заполнение реестра адресатов отправленных писем с других листов
Изменено: МатросНаЗебре - 25.08.2022 16:58:55
 
 
 
#3
26.08.2022 13:35:04
Цитата
написал:
Sub FillRegistry()    Dim dic As Object    Set dic = CreateObject("Scripting.Dictionary")    dic.Item(Sheets("Маленький").Range("D1").Value) = 0    dic.Item(Sheets("Длинный").Range("D1").Value) = 0    dic.Item(Sheets("Большой").Range("E2").Value) = 0         If dic.Exists(Empty) Then dic.Remove Empty    If dic.Count Then        With Sheets("РЕЕСТР")            With .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(dic.Count)                .Columns(1).Value = Date                .Columns(2).Value = Application.Transpose(dic.Keys())            End With        End With    End IfEnd Sub
СПС огромное! А как сделать автоматическое выполнение макроса, чтоб каждый раз не нажимать "выполнить"?
 
 
 
#4
26.08.2022 14:40:24
В модули листов
Код
'"Маленький" и "Длинный"
Private Sub Worksheet_Change(ByVal Target As Range)
    Const RANGE_ADDRESS = "D1"
    If Not Intersect(Target, Range(RANGE_ADDRESS)) Is Nothing Then
        With Sheets("ÐÅÅÑÒÐ")
            .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 2).Value = Array(Date, Range(RANGE_ADDRESS).Value)
        End With
    End If
End Sub
Код
'Большой
Private Sub Worksheet_Change(ByVal Target As Range)
    Const RANGE_ADDRESS = "E2"
    If Not Intersect(Target, Range(RANGE_ADDRESS)) Is Nothing Then
        With Sheets("РЕЕСТР")
            .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 2).Value = Array(Date, Range(RANGE_ADDRESS).Value)
        End With
    End If
End Sub
 
 
 
Страницы: 1
Наверх