Vertikaal zoeken met behoud van opmaak

[Philly]

Ik maak gebruik van de functie vertikaal zoeken. De broncel bevat tekst
waarvan enkele letters cq woorden vetgedrukt zijn. Nu wil ik graag dat deze
opmaak meegenomen wordt bij het plaatsen van het resultaat.
Gezien het feit dat het willekeurig is welke woorden cq letters vetgedrukt
zijn, kan ik geen gebruik maken van de voorwaardelijke opmaak.
Het zou misschien wel gaan met een VBA-code. Alleen reikt mijn kennis nog
niet ver genoeg om zo'n code te maken.
Wie kan mij hierbij helpen?

Philly

[Jan B.]

Philly,

Met opmaak of voorwaardelijke opmaak een deel van de tekst vet maken is ook
niet mogelijk.
Zelfs het kopieren van opmaak, die zich in een deel van tekst bevindt, is
niet mogelijk.
Jammer, maar helaas.

--
met vriendelijke groet,
Jan B.

"Philly" schreef:

[Philly]

Jan, zou het ook niet mogelijk zijn met een macro?

[Jan B.]

Dan zul je die macro bij elke zoekactie moeten activeren.
lijkt me niet echt practisch.
Ik heb toch eens geprobeerd of een kopieerslag met een macro dit voor elkaar
krijgt.
Neen, helaas.

[Philly]

Jammer, toch bedankt voor je reactie.

[Floris]

Philly,

misschien is dit een oplossing,
Voer in een cel de vert.zoeken formule in, plaats de onderstaande code in de
worksheetmodule van de sheet waar het verticaal zoeken plaatsvindt.
Ik heb em nog niet zover dat de code ook de cel met de vert.zoeken formule
opzoekt, verander daarom de waarde van formulecel in de het adres van de
vert.zoeken cel. Als het goed is zal, als de op te zoeken waarde wordt
gewijzigd, de opmaak nu mee worden genomen,

'-------------------------- begin code ------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rfound, bereik, cel, zoekwaarde, kolom, doel, waarden
Dim actievecel, formulecel

On Error GoTo foutje

Set actievecel = ActiveCell

formulecel = "d1"

waarden = Split(Replace(Replace(LCase(Range(formulecel).Formula), _
"=vlookup(", ""), ")", ""), ",")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

If LCase(Replace(Target.Address, "$", "")) = LCase(waarden(0)) _
Then
zoekwaarde = Range(waarden(0))
Set doel = Range(formulecel)
For Each cel In ActiveSheet.Range(waarden(1))
If cel = zoekwaarde Then
cel.Offset(0, waarden(2) - 1).Copy
doel.PasteSpecial Paste:=xlPasteFormats
End If
Next

Set doel = Nothing
End If

actievecel.Select

foutje:

Set doel = Nothing
Set actievecel = Nothing

With Application
.EnableEvents = True
.CutCopyMode = False
End With
End Sub
'-------------------------- einde code ------------------------------

Floris

[Floris]

nog een paar aanpassingen gedaan..,

er hoeft nu niks meer te worden ingevoerd,

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngBereik As Range
Dim rngCel As Range
Dim rngDoel As Range
Dim arrWaarden As Variant
Dim rngActievecel As Range
Dim rFnd
Dim rFirstAddress
Dim arMatches As Variant
Dim intTeller%

On Error GoTo foutje

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

arMatches = Array()

Set rngActievecel = ActiveCell
Set rngBereik = Range(Cells(1, 1), _
Cells(Cells.SpecialCells(xlLastCell).Row, _
Cells.SpecialCells(xlLastCell).Column))
Set rFnd = Range(rngBereik.Address).Find(What:="vlookup", _
LookIn:=xlFormulas, LookAt:=xlPart)

Erase arMatches

If Not rFnd Is Nothing Then
rFirstAddress = rFnd.Address
Do Until rFnd Is Nothing
ReDim Preserve arMatches(intTeller)
arMatches(intTeller) = rFnd.Address
intTeller = intTeller + 1
Set rFnd = Range(rngBereik.Address).FindNext(rFnd)
If rFnd.Address = rFirstAddress Then Exit Do
Loop
End If

For intTeller = 1 To UBound(arMatches)
arrWaarden = _
Split(Replace(Replace(LCase(Range(arMatches(intTeller)).Formula), _

"=vlookup(", ""), ")", ""), ",")

Set rngDoel = Range(arMatches(intTeller))
For Each rngCel In ActiveSheet.Range(arrWaarden(1))
If rngCel = Range(arrWaarden(0)) Then
rngCel.Offset(0, arrWaarden(2) - 1).Copy
rngDoel.PasteSpecial Paste:=xlPasteFormats
Exit For
End If
Next
Next intTeller%

foutje:

If Err <> 0 Then
MsgBox Err.Number & " " & Err.Description, vbInformation, _
"Find All"
Err.Clear
End If

With Application
.EnableEvents = True
.CutCopyMode = False
End With

rngActievecel.Select

Set rngDoel = Nothing
Set rngActievecel = Nothing
Set rFnd = Nothing
Set rngBereik = Nothing
End Sub

Floris