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

Вход

Регистрация

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

 

= Мир MS Excel/Не копирует в UDF - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Не копирует в UDF (Макросы/Sub)
Не копирует в UDF
skais Дата: Четверг, 07.06.2018, 07:38 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 1 ±
Замечаний: 60% ±

Excel 2010
Пытаюсь доработать, но не копирует формат, может кто поможет? Суть была в пользовательской функции ВПР с копированием формата.
При прямом назначение свойств и форматов все работает, а вот копирование формата или значений не работает.
Тема обсуждалась здесь
[vba]
Код
Function vpr(r1 As Range, r2 As Range, c As Integer)
    If IsError(Application.VLookup(r1, r2, c, 0)) Then
        vpr = ""
        With Application.Caller
        .Parent.Evaluate "RChangeit(" & .Address(False, False) & ")"
        End With
        Exit Function
    End If
    If Application.VLookup(r1, r2, c, 0) = "" Then
        vpr = ""
    Else
        vpr = Application.VLookup(r1, r2, c, 0)
    End If
    crw = Application.Match(r1, Application.WorksheetFunction.Index(r2, 0, 1), 0)
    cii = Application.WorksheetFunction.Index(r2, crw, c).Worksheet.Name & "!" & Application.WorksheetFunction.Index(r2, crw, c).Address(False, False)
    'MsgBox cii
    With Application.Caller
        .Parent.Evaluate "Changeit(" & .Address(False, False) & "," & cii & ")"
    End With
End Function

Sub ChangeIt(c1 As Range, c2 As Range)
    'MsgBox 1
    c2.Copy
    'MsgBox c2.Value
    c1.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     
    'MsgBox c2.Worksheet.Name + c2.Address
End Sub

Sub RChangeIt(c1 As Range)
    c1.ClearFormats
End Sub
[/vba]
К сообщению приложен файл: ____2-1-.xlsm(24.1 Kb)


Сообщение отредактировал skais - Четверг, 07.06.2018, 13:50
 
Ответить
СообщениеПытаюсь доработать, но не копирует формат, может кто поможет? Суть была в пользовательской функции ВПР с копированием формата.
При прямом назначение свойств и форматов все работает, а вот копирование формата или значений не работает.
Тема обсуждалась здесь
[vba]
Код
Function vpr(r1 As Range, r2 As Range, c As Integer)
    If IsError(Application.VLookup(r1, r2, c, 0)) Then
        vpr = ""
        With Application.Caller
        .Parent.Evaluate "RChangeit(" & .Address(False, False) & ")"
        End With
        Exit Function
    End If
    If Application.VLookup(r1, r2, c, 0) = "" Then
        vpr = ""
    Else
        vpr = Application.VLookup(r1, r2, c, 0)
    End If
    crw = Application.Match(r1, Application.WorksheetFunction.Index(r2, 0, 1), 0)
    cii = Application.WorksheetFunction.Index(r2, crw, c).Worksheet.Name & "!" & Application.WorksheetFunction.Index(r2, crw, c).Address(False, False)
    'MsgBox cii
    With Application.Caller
        .Parent.Evaluate "Changeit(" & .Address(False, False) & "," & cii & ")"
    End With
End Function

Sub ChangeIt(c1 As Range, c2 As Range)
    'MsgBox 1
    c2.Copy
    'MsgBox c2.Value
    c1.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     
    'MsgBox c2.Worksheet.Name + c2.Address
End Sub

Sub RChangeIt(c1 As Range)
    c1.ClearFormats
End Sub
[/vba]

Автор - skais
Дата добавления - 07.06.2018 в 07:38
Hugo Дата: Четверг, 07.06.2018, 09:36 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2854
Репутация: 639 ±
Замечаний: 0% ±

Application.Caller=Error 2023
А в предыдущей версии всё ОК. Мистика...
P.S. пропало, есть значение. Но не копирует.


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069


Сообщение отредактировал Hugo - Четверг, 07.06.2018, 09:45
 
Ответить
СообщениеApplication.Caller=Error 2023
А в предыдущей версии всё ОК. Мистика...
P.S. пропало, есть значение. Но не копирует.

Автор - Hugo
Дата добавления - 07.06.2018 в 09:36
SLAVICK Дата: Четверг, 07.06.2018, 10:49 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2272
Репутация: 750 ±
Замечаний: 0% ±

2007,2010,2013,2016
А в предыдущей версии всё ОК

там также.
С копи-пастом не вышло применить...

Блин - вы ломаете мои стереотипы :D - я был уверен, что менять заливку формулой - практически невозможно.
Есть хороший макрос по применению ВИДИМЫХ (это важно - учитывается УФ) форматов, его сделал RAN тут - я просто вырвал его кусок.
Получилось интересное решение - думаю достойно готового решения.:
[vba]
Код
Function vpr(r1 As Range, r2 As Range, c As Integer)
    If IsError(Application.VLookup(r1, r2, c, 0)) Then
        vpr = ""
        With Application.Caller
        .Parent.Evaluate "RChangeit(" & .Address(False, False) & ")"
        End With
        Exit Function
    End If
    If Application.VLookup(r1, r2, c, 0) = "" Then
        vpr = ""
    Else
        vpr = Application.VLookup(r1, r2, c, 0)
    End If
    crw = Application.Match(r1, Application.WorksheetFunction.Index(r2, 0, 1), 0)
    cii = Application.WorksheetFunction.Index(r2, crw, c).Interior.ColorIndex
    
    With Application.Caller
'        .Parent.Evaluate "rChangeit(" & .Address(False, False) & ")"
        .Parent.Evaluate "ApplyCellFormatsFromFormatConditions(" & .Address(False, False) & ", '" & r2.Parent.Name & "'!" & Application.WorksheetFunction.Index(r2, crw, c).Address & ")"
    End With
End Function

'Sub ChangeIt(c1 As Range, ci As Integer)
'    c1.Interior.ColorIndex = ci
'End Sub

Sub RChangeIt(c1 As Range)
    c1.Interior.Color = xlNone
End Sub

Private Sub ApplyCellFormatsFromFormatConditions(CellPaste As Range, CellCopy As Range)
Dim dfBorders As Object, dfFont As Object, dfInterior As Object
Dim i&
    
'    CellPaste.NumberFormat = CellCopy.NumberFormat

    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%
    Set dfBorders = CellCopy.DisplayFormat.Borders
    With CellPaste.Borders
        For i = 1 To 4
            .Item(i).LineStyle = dfBorders.Item(i).LineStyle
            .Item(i).ColorIndex = dfBorders.Item(i).ColorIndex
        Next
    End With
    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%

    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
    Set dfFont = CellCopy.DisplayFormat.Font
    With CellPaste.Font
        .Color = dfFont.Color
        .Bold = dfFont.Bold
        .Italic = dfFont.Italic
        .Strikethrough = dfFont.Strikethrough
        .Underline = dfFont.Underline
        .Background = dfFont.Background
    End With
    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
   
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
    Set dfInterior = CellCopy.DisplayFormat.Interior
    With CellPaste.Interior
        If Not dfInterior.Gradient Is Nothing Then
            .Pattern = dfInterior.Pattern
            Do While .Gradient.ColorStops.Count < dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops.Add (0)
                DoEvents
            Loop
            If .Pattern = 4001 Then
                .Gradient.RectangleLeft = dfInterior.Gradient.RectangleLeft
                .Gradient.RectangleRight = dfInterior.Gradient.RectangleRight
                .Gradient.RectangleTop = dfInterior.Gradient.RectangleTop
                .Gradient.RectangleBottom = dfInterior.Gradient.RectangleBottom
            Else
                .Gradient.Degree = dfInterior.Gradient.Degree
            End If
            For i = 1 To dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops(i).Color = dfInterior.Gradient.ColorStops(i).Color
                .Gradient.ColorStops(i).Position = dfInterior.Gradient.ColorStops(i).Position
                If dfInterior.Gradient.ColorStops(i).ThemeColor Then _
                .Gradient.ColorStops(i).ThemeColor = dfInterior.Gradient.ColorStops(i).ThemeColor
                .Gradient.ColorStops(i).TintAndShade = dfInterior.Gradient.ColorStops(i).TintAndShade
            Next
        Else
            .Pattern = dfInterior.Pattern
            If .Pattern <> xlPatternNone Then
                .Color = dfInterior.Color
                .PatternColor = dfInterior.PatternColor
            End If
        End If
    End With
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
End Sub
[/vba]
К сообщению приложен файл: ____2.xlsm(25.9 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
А в предыдущей версии всё ОК

там также.
С копи-пастом не вышло применить...

Блин - вы ломаете мои стереотипы :D - я был уверен, что менять заливку формулой - практически невозможно.
Есть хороший макрос по применению ВИДИМЫХ (это важно - учитывается УФ) форматов, его сделал RAN тут - я просто вырвал его кусок.
Получилось интересное решение - думаю достойно готового решения.:
[vba]
Код
Function vpr(r1 As Range, r2 As Range, c As Integer)
    If IsError(Application.VLookup(r1, r2, c, 0)) Then
        vpr = ""
        With Application.Caller
        .Parent.Evaluate "RChangeit(" & .Address(False, False) & ")"
        End With
        Exit Function
    End If
    If Application.VLookup(r1, r2, c, 0) = "" Then
        vpr = ""
    Else
        vpr = Application.VLookup(r1, r2, c, 0)
    End If
    crw = Application.Match(r1, Application.WorksheetFunction.Index(r2, 0, 1), 0)
    cii = Application.WorksheetFunction.Index(r2, crw, c).Interior.ColorIndex
    
    With Application.Caller
'        .Parent.Evaluate "rChangeit(" & .Address(False, False) & ")"
        .Parent.Evaluate "ApplyCellFormatsFromFormatConditions(" & .Address(False, False) & ", '" & r2.Parent.Name & "'!" & Application.WorksheetFunction.Index(r2, crw, c).Address & ")"
    End With
End Function

'Sub ChangeIt(c1 As Range, ci As Integer)
'    c1.Interior.ColorIndex = ci
'End Sub

Sub RChangeIt(c1 As Range)
    c1.Interior.Color = xlNone
End Sub

Private Sub ApplyCellFormatsFromFormatConditions(CellPaste As Range, CellCopy As Range)
Dim dfBorders As Object, dfFont As Object, dfInterior As Object
Dim i&
    
'    CellPaste.NumberFormat = CellCopy.NumberFormat

    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%
    Set dfBorders = CellCopy.DisplayFormat.Borders
    With CellPaste.Borders
        For i = 1 To 4
            .Item(i).LineStyle = dfBorders.Item(i).LineStyle
            .Item(i).ColorIndex = dfBorders.Item(i).ColorIndex
        Next
    End With
    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%

    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
    Set dfFont = CellCopy.DisplayFormat.Font
    With CellPaste.Font
        .Color = dfFont.Color
        .Bold = dfFont.Bold
        .Italic = dfFont.Italic
        .Strikethrough = dfFont.Strikethrough
        .Underline = dfFont.Underline
        .Background = dfFont.Background
    End With
    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
   
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
    Set dfInterior = CellCopy.DisplayFormat.Interior
    With CellPaste.Interior
        If Not dfInterior.Gradient Is Nothing Then
            .Pattern = dfInterior.Pattern
            Do While .Gradient.ColorStops.Count < dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops.Add (0)
                DoEvents
            Loop
            If .Pattern = 4001 Then
                .Gradient.RectangleLeft = dfInterior.Gradient.RectangleLeft
                .Gradient.RectangleRight = dfInterior.Gradient.RectangleRight
                .Gradient.RectangleTop = dfInterior.Gradient.RectangleTop
                .Gradient.RectangleBottom = dfInterior.Gradient.RectangleBottom
            Else
                .Gradient.Degree = dfInterior.Gradient.Degree
            End If
            For i = 1 To dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops(i).Color = dfInterior.Gradient.ColorStops(i).Color
                .Gradient.ColorStops(i).Position = dfInterior.Gradient.ColorStops(i).Position
                If dfInterior.Gradient.ColorStops(i).ThemeColor Then _
                .Gradient.ColorStops(i).ThemeColor = dfInterior.Gradient.ColorStops(i).ThemeColor
                .Gradient.ColorStops(i).TintAndShade = dfInterior.Gradient.ColorStops(i).TintAndShade
            Next
        Else
            .Pattern = dfInterior.Pattern
            If .Pattern <> xlPatternNone Then
                .Color = dfInterior.Color
                .PatternColor = dfInterior.PatternColor
            End If
        End If
    End With
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
End Sub
[/vba]

Автор - SLAVICK
Дата добавления - 07.06.2018 в 10:49
_Boroda_ Дата: Четверг, 07.06.2018, 11:03 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13187
Репутация: 5422 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Ярослав, вот посмотри. Там пример, правда, не совсем тот, но суть ясна
http://forum.script-coding.com/viewtopic.php?id=9522


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЯрослав, вот посмотри. Там пример, правда, не совсем тот, но суть ясна
http://forum.script-coding.com/viewtopic.php?id=9522

Автор - _Boroda_
Дата добавления - 07.06.2018 в 11:03
skais Дата: Четверг, 07.06.2018, 11:30 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 1 ±
Замечаний: 60% ±

Excel 2010
SLAVICK, Вы ушли от темы, я ж писал что в лоб назначить форматы не проблема (значение передаем, цвет тоже ну и остальное аналогично можно назначить, но это куча телодвижений, вместо того чтоб просто скопировать), а вот почему копирование не работает?


Сообщение отредактировал skais - Четверг, 07.06.2018, 11:31
 
Ответить
СообщениеSLAVICK, Вы ушли от темы, я ж писал что в лоб назначить форматы не проблема (значение передаем, цвет тоже ну и остальное аналогично можно назначить, но это куча телодвижений, вместо того чтоб просто скопировать), а вот почему копирование не работает?

Автор - skais
Дата добавления - 07.06.2018 в 11:30
SLAVICK Дата: Четверг, 07.06.2018, 11:46 | Сообщение № 6
Группа: Модераторы
Ранг: Старожил
Сообщений: 2272
Репутация: 750 ±
Замечаний: 0% ±

2007,2010,2013,2016
Вы ушли от темы

немного - просто интересная тема вышла. Кроме того если просто скопировать формат полностью - то если есть УФ - они могут не работать.

Посмотрел тут ссылку от _Boroda_ - таки можно и копировать - правда тут тоже есть
куча телодвижений,

см. пример.
Код можно немного оптимизировать - но пока как есть.
правда, не совсем тот, но суть ясна

да - круть specool . Теперь думаю как к своей надстройке это прикрутить, чтоб не быть привязанным к определенной книге.
К сообщению приложен файл: 9768369.xlsm(26.4 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Вы ушли от темы

немного - просто интересная тема вышла. Кроме того если просто скопировать формат полностью - то если есть УФ - они могут не работать.

Посмотрел тут ссылку от _Boroda_ - таки можно и копировать - правда тут тоже есть
куча телодвижений,

см. пример.
Код можно немного оптимизировать - но пока как есть.
правда, не совсем тот, но суть ясна

да - круть specool . Теперь думаю как к своей надстройке это прикрутить, чтоб не быть привязанным к определенной книге.

Автор - SLAVICK
Дата добавления - 07.06.2018 в 11:46
skais Дата: Четверг, 07.06.2018, 12:26 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 1 ±
Замечаний: 60% ±

Excel 2010
SLAVICK, Работает, но конечно через Владивосток, но респект!
А в чем причина почему из UDF вызов макроса не позволяет произвести копирование, что-то блокируется на этот момент? Или в чем собственно причина?
 
Ответить
СообщениеSLAVICK, Работает, но конечно через Владивосток, но респект!
А в чем причина почему из UDF вызов макроса не позволяет произвести копирование, что-то блокируется на этот момент? Или в чем собственно причина?

Автор - skais
Дата добавления - 07.06.2018 в 12:26
SLAVICK Дата: Четверг, 07.06.2018, 12:30 | Сообщение № 8
Группа: Модераторы
Ранг: Старожил
Сообщений: 2272
Репутация: 750 ±
Замечаний: 0% ±

2007,2010,2013,2016
что-то блокируется на этот момент? Или в чем собственно причина

Причина в ограничениях пользовательских функций
Поэтому напрямую и нельзя многого сделать - только через "финты ушами" :) .

Я до этого дня думал что менять заливку в функции сразу, можно только через XML книги - оказывается можно и проще, но тут тоже есть свои неудобства, и особенности.
Мне кажется, что при использовании 2-го варианта - возможны страшные бАги - поэтому я бы это использовал очень осторожно... хотя может - это просто страх перед неизвестностью :D .

Но себе забираю в копилку два варианта - первый - безопасный - второй - буду еще смотреть и тестить.

Добавлено
не из того окна ссылку скопировал: ВОТ про ограничения


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Четверг, 07.06.2018, 12:46
 
Ответить
Сообщение
что-то блокируется на этот момент? Или в чем собственно причина

Причина в ограничениях пользовательских функций
Поэтому напрямую и нельзя многого сделать - только через "финты ушами" :) .

Я до этого дня думал что менять заливку в функции сразу, можно только через XML книги - оказывается можно и проще, но тут тоже есть свои неудобства, и особенности.
Мне кажется, что при использовании 2-го варианта - возможны страшные бАги - поэтому я бы это использовал очень осторожно... хотя может - это просто страх перед неизвестностью :D .

Но себе забираю в копилку два варианта - первый - безопасный - второй - буду еще смотреть и тестить.

Добавлено
не из того окна ссылку скопировал: ВОТ про ограничения

Автор - SLAVICK
Дата добавления - 07.06.2018 в 12:30
skais Дата: Четверг, 07.06.2018, 13:25 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 1 ±
Замечаний: 60% ±

Excel 2010
Почти тоже самое, но наверно поизящней. Наконец то свершилось!
SLAVICK, спасибо!
К сообщению приложен файл: fc3.xlsm(17.7 Kb)


Сообщение отредактировал skais - Четверг, 07.06.2018, 13:40
 
Ответить
СообщениеПочти тоже самое, но наверно поизящней. Наконец то свершилось!
SLAVICK, спасибо!

Автор - skais
Дата добавления - 07.06.2018 в 13:25
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Не копирует в UDF (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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