Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Копирование/вставка значений и форматов в событиях календаря - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование/вставка значений и форматов в событиях календаря (Макросы/Sub)
Копирование/вставка значений и форматов в событиях календаря
Anis625 Дата: Воскресенье, 27.09.2020, 18:11 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 435
Репутация: 14 ±
Замечаний: 0% ±

Excel 2013
Добрый вечер, участникам форума!

Давно пользуюсь готовым решением с этого же форума (тут) для создания событий в календарях участников. Но появилась необходимость в копировании из ячеек не только текста, но и формата (т.к. в некоторых местах по тексту применяю и жирный формат и цвет отличный от черного).
Пытался самостоятельно дописать сюда
[vba]
Код
.Body = Cells(X, 5).Value & vbNewLine & vbNewLine & Others 'Текст
[/vba]
чтобы формат ячейки тоже перенеслось но увы вынужден обратиться за советом к знающим специалистам VBA.

Подскажите, пожалуйста, как правильно дописать код.
Полная версия кода:
[vba]
Код
Sub Rio_OutLook_Time_Manager()

Dim olApp As Object  'Для обращений к приложению АутЛук
Dim NewX As Object   'Для создания объекта события
Dim Others As String 'Для работы со списком людей
Dim NewMan As Object 'Для добавления нового участника

Dim They             'Массив приглашенных
Dim R As Byte        'Обработка события
Dim X As Long        'Для перебора строк
Dim A As Long        'Для перебора участников
Dim H As Long        'Высота Таблицы

H = Cells(Rows.Count, 1).End(xlUp).Row
If H < 2 Then Exit Sub
Set olApp = CreateObject("Outlook.Application")

For X = 2 To H
    Select Case Cells(X, 1).Value
        Case "": R = 0
        Case "Собрание": R = 1
        Case "Встреча": R = 2
    End Select
    If R > 0 Then
        Set NewX = olApp.CreateItem(1)
        With NewX
            .MeetingStatus = R
            They = Split(Cells(X, 4).Value, ", ")
            Select Case R
                Case 1
                    For A = 0 To UBound(They)
                        Others = "<" & They(A) & ">"
                        Set NewMan = NewX.Recipients.Add(Others)
                        NewMan.Type = 1
                    Next A
                    Others = ""
                Case 2
                    Others = "Участники встречи:" & vbNewLine & vbNewLine
                    For A = 0 To UBound(They)
                        Others = Others & They(A) & vbNewLine
                    Next A
            End Select
            .Subject = Cells(X, 2).Value
            .Location = Cells(X, 3).Value
            .Body = Cells(X, 5).Value & vbNewLine & vbNewLine & Others 'Текст
            .Categories = Cells(X, 6).Value
            .Start = Cells(X, 7).Value + Cells(X, 8).Value
            .End = Cells(X, 9).Value + Cells(X, 10).Value
            If Cells(X, 11).Value = "Да" Then
                .ReminderSet = True
                .ReminderMinutesBeforeStart = Cells(X, 12).Value
            Else
                .ReminderSet = False
            End If
            Select Case R
                Case 1: .Send
                Case 2: .Save
            End Select
        End With
    End If
Next X

Set They = Nothing
Set NewMan = Nothing
Set NewX = Nothing
Set olApp = Nothing

End Sub
[/vba]


Сообщение отредактировал Anis625 - Воскресенье, 27.09.2020, 18:16
 
Ответить
СообщениеДобрый вечер, участникам форума!

Давно пользуюсь готовым решением с этого же форума (тут) для создания событий в календарях участников. Но появилась необходимость в копировании из ячеек не только текста, но и формата (т.к. в некоторых местах по тексту применяю и жирный формат и цвет отличный от черного).
Пытался самостоятельно дописать сюда
[vba]
Код
.Body = Cells(X, 5).Value & vbNewLine & vbNewLine & Others 'Текст
[/vba]
чтобы формат ячейки тоже перенеслось но увы вынужден обратиться за советом к знающим специалистам VBA.

Подскажите, пожалуйста, как правильно дописать код.
Полная версия кода:
[vba]
Код
Sub Rio_OutLook_Time_Manager()

Dim olApp As Object  'Для обращений к приложению АутЛук
Dim NewX As Object   'Для создания объекта события
Dim Others As String 'Для работы со списком людей
Dim NewMan As Object 'Для добавления нового участника

Dim They             'Массив приглашенных
Dim R As Byte        'Обработка события
Dim X As Long        'Для перебора строк
Dim A As Long        'Для перебора участников
Dim H As Long        'Высота Таблицы

H = Cells(Rows.Count, 1).End(xlUp).Row
If H < 2 Then Exit Sub
Set olApp = CreateObject("Outlook.Application")

For X = 2 To H
    Select Case Cells(X, 1).Value
        Case "": R = 0
        Case "Собрание": R = 1
        Case "Встреча": R = 2
    End Select
    If R > 0 Then
        Set NewX = olApp.CreateItem(1)
        With NewX
            .MeetingStatus = R
            They = Split(Cells(X, 4).Value, ", ")
            Select Case R
                Case 1
                    For A = 0 To UBound(They)
                        Others = "<" & They(A) & ">"
                        Set NewMan = NewX.Recipients.Add(Others)
                        NewMan.Type = 1
                    Next A
                    Others = ""
                Case 2
                    Others = "Участники встречи:" & vbNewLine & vbNewLine
                    For A = 0 To UBound(They)
                        Others = Others & They(A) & vbNewLine
                    Next A
            End Select
            .Subject = Cells(X, 2).Value
            .Location = Cells(X, 3).Value
            .Body = Cells(X, 5).Value & vbNewLine & vbNewLine & Others 'Текст
            .Categories = Cells(X, 6).Value
            .Start = Cells(X, 7).Value + Cells(X, 8).Value
            .End = Cells(X, 9).Value + Cells(X, 10).Value
            If Cells(X, 11).Value = "Да" Then
                .ReminderSet = True
                .ReminderMinutesBeforeStart = Cells(X, 12).Value
            Else
                .ReminderSet = False
            End If
            Select Case R
                Case 1: .Send
                Case 2: .Save
            End Select
        End With
    End If
Next X

Set They = Nothing
Set NewMan = Nothing
Set NewX = Nothing
Set olApp = Nothing

End Sub
[/vba]

Автор - Anis625
Дата добавления - 27.09.2020 в 18:11
Pelena Дата: Воскресенье, 27.09.2020, 18:50 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16641
Репутация: 3598 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
Целиком формат не знаю, а цвет шрифта и полужирный можно так (наверное), не проверяла
[vba]
Код
.Font.Color = Cells(X, 5).Font.Color
.Font.Bold = Cells(X, 5).Font.Bold
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Целиком формат не знаю, а цвет шрифта и полужирный можно так (наверное), не проверяла
[vba]
Код
.Font.Color = Cells(X, 5).Font.Color
.Font.Bold = Cells(X, 5).Font.Bold
[/vba]

Автор - Pelena
Дата добавления - 27.09.2020 в 18:50
Anis625 Дата: Воскресенье, 27.09.2020, 19:02 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 435
Репутация: 14 ±
Замечаний: 0% ±

Excel 2013
Pelena,
Там не весь текст красный или жирный, а только некоторые слова. Если без макросов COPY ячейки PAST в новое событие календаря то вставляется формат как надо. Пытался заменить Select на Copy - не работает
 
Ответить
СообщениеPelena,
Там не весь текст красный или жирный, а только некоторые слова. Если без макросов COPY ячейки PAST в новое событие календаря то вставляется формат как надо. Пытался заменить Select на Copy - не работает

Автор - Anis625
Дата добавления - 27.09.2020 в 19:02
Pelena Дата: Воскресенье, 27.09.2020, 19:19 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 16641
Репутация: 3598 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
К сожалению, проверить не на чем. Так не работает?
[vba]
Код
Cells(X, 5).Copy .Body
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеК сожалению, проверить не на чем. Так не работает?
[vba]
Код
Cells(X, 5).Copy .Body
[/vba]

Автор - Pelena
Дата добавления - 27.09.2020 в 19:19
Anis625 Дата: Воскресенье, 27.09.2020, 19:38 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 435
Репутация: 14 ±
Замечаний: 0% ±

Excel 2013
Pelena,
На эту строку начинает ругаться =(
 
Ответить
СообщениеPelena,
На эту строку начинает ругаться =(

Автор - Anis625
Дата добавления - 27.09.2020 в 19:38
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование/вставка значений и форматов в событиях календаря (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!