Страницы: 1
RSS
Формат текста при функции ВПР
 
Добрый день. Подскажите, пожалуйста, как сохранить формат текста в ячейке при её поиске через ВПР? При переносе информации пропадает подчеркивание, жирный текст, надстрочный текст. Можно ли настроить перенос формата или как возможно реализовать поиск данных как-то иначе?
 
Этот макрос заменит формулы выделенных ячеек на значения. И вставит форматирование ячеек, из которых ВПР получает значения.
Код
Sub ВПРф()
    Dim rs As Range
    On Error Resume Next
    Set rs = Selection.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    
    Dim cl As Range
    For Each cl In rs.Cells
        VPRcell cl
    Next
End Sub

Private Sub VPRcell(cl As Range)
    Dim sf As String
    sf = cl.Formula
    If Not sf Like "=VLOOKUP(*,*,#,*)" Then Exit Sub
    
    sf = Mid(sf, Len("=VLOOKUP(") + 1)
    sf = Left(sf, Len(sf) - 1)
    
    Dim arf As Variant
    arf = Split(sf, ",")
    
    Dim rs As Range
    On Error Resume Next
    Set rs = Range(arf(1)).Cells(WorksheetFunction.Match(Range(arf(0)), Range(arf(1)).Columns(1), 0), CLng(arf(2)))
    On Error GoTo 0
    If rs Is Nothing Then Exit Sub
    
    rs.Copy cl
    Application.CutCopyMode = False
End Sub

 
Спасибо! Подходит, но частично. В документе часто приходится менять вводные и распечатывать документ, а так как данный макрос именно заменяет формулы, то будет необходимо закрывать файл без сохранения - вводить данные - использовать макрос и т.д.. Верно понимаю? Это единственный вариант?

upd: Даже не подходит. Данный макрос не работает на объединенные ячейки. А в форме, которую необходимо печатать, их много.  
Изменено: Timchest - 14.05.2024 19:27:07
 
Timchest, никакие формулы не умеют сохранять формат исходных. Тут либо макрос который найдет что нужно и скопирует ячейку с форматами, только он не будет функцией листа, либо ничего.
По вопросам из тем форума, личку не читаю.
 
БМВ, Спасибо за информацию! А не будет сложно подсказать пример такого макроса? И как понять "только он не будет функцией листа"? - придется каждый раз выполнять данный макрос для поиска, верно?  
 
Цитата
Timchest написал:
придется каждый раз выполнять данный макрос для поиска, верно?  
да именно так.

Ну макрописец из меня никакой, но осуществить поиск тем же штатным поиском в определенном диапазоне, взять со смещением ячейку из найденной строки и вставить в нужное место - проще простого. При этом я б использовал  Distination.VALUE(11)=FindCell.Offset(,1).value(11) дело не хитрое.
Код
With Range("A6")
Set res = Range("A1:A3").Find(What:=.Value)
If Not res Is Nothing Then
.Offset(, 1).Value(11) = res.Offset(, 1).Value(11)
.Offset(1, 1).Value(11) = res.Offset(, 2).Value(11)

Else
.Offset(1, 1).ClearContents
.Offset(, 1).ClearContents
End If
End With
Изменено: БМВ - 14.05.2024 22:18:58
По вопросам из тем форума, личку не читаю.
 
Всем привет.
Если чуть глобальнее подойти - можно небольшую функцию сделать.
Код
=ИНДЕКС_В(Ячейка_приемник; Ссылка; Номер_строки; Номер_столбца)
Ячейка_приемник - куда копировать.
Ссылка, Номер_строки, Номер_столбца - параметры как в функции ИНДЕКС().

Пример - в A9 (копирует в B9 полное содержимое Bnn, где nn - результат поиска A6 в столбце A, здесь B1):
Код
=ИНДЕКС_В(B9; B:B; ПОИСКПОЗ($A$6; A:A; 0))
Код функции:
Код
Function ИНДЕКС_В(Ячейка As Range, Ссылка As Range, Optional Номер_строки As Long, Optional Номер_столбца As Long)
Application.Volatile ' для отслеживания изменений формата ячейки
    
    Dim lResult As Boolean
    
    lResult = (Номер_строки >= 0 And Номер_столбца >= 0 And Номер_строки + Номер_столбца > 0)
    lResult = lResult And (Номер_строки <= Ссылка.Rows.Count And Номер_столбца <= Ссылка.Columns.Count)
    
    Номер_строки = Номер_строки - 1
    Номер_столбца = Номер_столбца - 1
    '?( поведение ИНДЕКС(ссылка;строка;), ИНДЕКС(ссылка;;столбец)
    If Номер_строки < 0 Then Номер_строки = 0
    If Номер_столбца < 0 Then Номер_столбца = 0
    ')
    
    If lResult Then
        With Ссылка.Offset(Номер_строки, Номер_столбца)
            Ячейка.Value(xlRangeValueXMLSpreadsheet) = .Value(xlRangeValueXMLSpreadsheet)
            ИНДЕКС_В = .Value
        End With
    Else
        Ячейка.Value = WorksheetFunction.NA()
    End If

End Function
Изменено: andypetr - 15.05.2024 09:32:28
 
Цитата
andypetr написал:
Application.Volatile ' для отслеживания изменений формата ячейки
не совсем, все что сделано с ячейкой а не со значением не приводит к запуску функции. То есть заболдить всю ячейку можно, но это не изменит результат.
По вопросам из тем форума, личку не читаю.
 
Это-то да, но по F9 всё обновится.
 
Код
Sub ВПРф()
    Dim rs As Range
    On Error Resume Next
    Set rs = Selection.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    
    Dim cl As Range
    For Each cl In rs.Cells
        VPRcell cl
    Next
End Sub

Private Sub VPRcell(cl As Range)
    Dim sf As String
    sf = cl.Formula
    If Not sf Like "=VLOOKUP(*,*,#,*)" Then Exit Sub
    
    sf = Mid(sf, Len("=VLOOKUP(") + 1)
    sf = Left(sf, Len(sf) - 1)
    
    Dim arf As Variant
    arf = Split(sf, ",")
    
    Dim rs As Range
    On Error Resume Next
    Set rs = Range(arf(1)).Cells(WorksheetFunction.Match(Range(arf(0)), Range(arf(1)).Columns(1), 0), CLng(arf(2)))
    On Error GoTo 0
    If rs Is Nothing Then Exit Sub
    
    'rs.Copy cl
    CopyCellFontFormat rs, cl
    
    Application.CutCopyMode = False
End Sub


Sub test()
    CopyCellFontFormat Range("B1"), Range("B12")
End Sub

Sub CopyCellFontFormat(clSource As Range, clTarget As Range)
    clTarget = clSource
    
    Dim fs As Font
    Dim ft As Font
    
    Dim ii As Long
    For ii = 1 To Len(clSource.Value)
        Set fs = clSource.Characters(Start:=ii, Length:=1).Font
        Set ft = clTarget.Characters(Start:=ii, Length:=1).Font
        
        ft.Name = fs.Name
        ft.FontStyle = fs.FontStyle
        ft.Size = fs.Size
        ft.Strikethrough = fs.Strikethrough
        ft.Superscript = fs.Superscript
        ft.Subscript = fs.Subscript
        ft.OutlineFont = fs.OutlineFont
        ft.Shadow = fs.Shadow
        ft.Underline = fs.Underline
        ft.Color = fs.Color
'        ft.TintAndShade = fs.TintAndShade
'        ft.ThemeFont = fs.ThemeFont
    Next
End Sub
Этот вариант работает и с объединёнными ячейками.
 
Что касается сохранения формул, можно создать "зеркало" листа. На одном листе хранить формулы, на печать отправлять лист со значениями.
 
И для коллекции - еще один способ решения подобных задач.
Владимир
 
sokol92, для разового  - пойдет, но если несколько на листе, то .....
По вопросам из тем форума, личку не читаю.
 
Здравствуйте, Михаил!

... придется потратить определенное время (или написать макрос)  :)  
Владимир
 
Поправил код UDF-функции: может работать с объединёнными ячейками.
Использование:
Код
=ИНДЕКС_В(Ячейка_приемник; Ссылка; Номер_строки; Номер_столбца)
Ячейка_приемник - куда копировать.
Ссылка, Номер_строки, Номер_столбца - параметры как в функции ИНДЕКС().
Пример - в A9 (копирует в B9 полное содержимое Bnn, где nn - результат поиска A6 в столбце A, здесь B1):
Код
=ИНДЕКС_В(B9; B:B; ПОИСКПОЗ($A$6; A:A; 0))
Код функции:
Скрытый текст
 
Цитата
andypetr написал:
Поправил код UDF-функции
Следует учитывать ограничения для UDF-функций.
Изменено: sokol92 - 15.05.2024 17:59:19
Владимир
 
БМВ, andypetr, МатросНаЗебре, sokol92, Большое спасибо вам! Не все варианты понял как пристроить, т.к. я овощ, но попытаюсь разобраться.
Страницы: 1
Наверх