Verschillende lettertypes en grote en kleur in 1 cel

Status
Niet open voor verdere reacties.
K

Killerclown

Gebruiker
Lid geworden
30 dec 2007
Berichten
181
Hey,

Ik heb een cel in excel die ik na invullen terug in oorspronkelijke staat zet door een stukje VBA-code.

De tekst in de cel staat in 4 verschillende lettertypes en grote en kleur.
Het lukt me maar niet om dat alles in code te gieten. 1 lettertype en grote en kleur lukt me op onderstaande manier:

Code: 
Range("B57").Value = "datum:……………………………" & vbCrLf & "Dr. " & TxtNaamD & "                " & TxtDoktersnummer & vbCrLf & TxtStraatD & " " & TxtNummerD & vbCrLf & TxtPostcodeD & " " & TxtGemeenteD & vbCrLf & "Tel: " & TxtTelefoonnummerD & " --- " & "Rizivnr: " & TxtRizivnummer & vbCrLf & "verklaart dat voor de aangevraagde testen met $ aan de diagnoseregel is voldaan"
Range("B57").Font.Color = RGB(0, 0, 0)
Range("B57").Font.Size = 8

Nu zou ik graag het volgende willen
- lettertype 1 en kleur 1 : "Datum:..........."
- lettertype 2 en kleur 1 : "Dr." & TxtNaamD
- lettertype 3 en kleur 2 en vetgedrukt : & TxtDoktersnummer
- lettertype 2 en kleur 1 : & TxtStraatD & " " & TxtNummerD & vbCrLf & TxtPostcodeD & " " & TxtGemeenteD & vbCrLf & "Tel: " & TxtTelefoonnummerD & " --- " & "Rizivnr: " & TxtRizivnummer
- lettertype 4 en kleur 3: & "verklaart dat voor de aangevraagde testen met $ aan de diagnoseregel is voldaan"

Kan iemand me verder helpen?

Alvast dank
 
In plaats van lettertype bedoel je waarschijnlijk lettergrootte, want je zult toch niet in 1 cel verschillende lettertypes (zoals Arial en Calibri) willen gebruiken neem ik aan.
Jij geeft de inhoud van de gehele cel een andere kleur, voor gedeelte(n) van een een cel heb je het object 'characters' nodig. Zie hiervoor de helfpile, waarin het gebruik daarvan duidelijk wordt uitgelegd. Je hebt nodig: de plaats waar de te wijzigen tekst begint en de lengte ervan. De plaats kun je vinden met 'search' en van alle stukjes tekst maak je een string, de lengte is dan bv. len(astring) als je een stuk tekst als astring hebt gedefinieerd. Verder is het veel eenvoudiger om voor de font een colorindexnummer (1-56) te gebruiken i.p.v. RGB. Met deze aanwijzingen zou het moeten lukken.
 
Mijn excuses, ik bedoelde inderdaad de lettergrootte

Ik heb geprobeerd met het object 'Characters' maar het probleem zit hem in de lengte.
De lengte van de velden TxtNaamD , TxtStraatD, TxtGemeenteD enz zijn variabel.

Probeersel 1
Code: 
ActiveCell.Characters(Start:=1, Length:=15).Font.size = 8

Probeersel 2
Code: 
cell_text = Range("B57").Value
text_array = Split(cell_text, " ")
length_1 = Len(text_array(0))
length_2 = Len(text_array(1) + text_array(2) + text_array(3))
length_3 = Len(text_array(4))
Length_4 = Len(text_array(5) + text_array(6))
ActiveCell.Characters(1, length_1).Font.Size = 10
ActiveCell.Characters(length_1 + 1, length_2).Font.Size = 8
Length_2 is bijvoorbeeld de doktersnaam (Dr. De Kleine) maar als de naam 1 of 3 delen bevat loopt het daar al mis (vb Dr. Klein of Dr. Van De Kleine)

Nu zit een beetje vast :-s
 
Ik heb geprobeerd met het object 'Characters' maar het probleem zit hem in de lengte.
De lengte van de velden TxtNaamD , TxtStraatD, TxtGemeenteD enz zijn variabel.
Klik om te vergroten...
Dat had ik gezien en daarom schreef ik hierboven:
van alle stukjes tekst maak je een string, de lengte is dan bv. len(astring) als je een stuk tekst als astring hebt gedefinieerd.
Met die aanwijzing heb je niets gedaan! Daarom maar een voorbeeld, gebaseerd op een deel van je gegevens uit je eerste bericht.
Code: 
Sub macro1()
Dim pstr As String, qstr As String, TxtNaamD As String, TxtDoktersnummer As String
Dim TxtStraatD As String, TxtNummerD As String
Dim intp As Integer, qint As Integer, rint As Integer
'Deze macro is geschreven door Zapatr
TxtNaamD = "Peeters": TxtDoktersnummer = 1027: TxtStraatD = "Klaverstraat": TxtNummerD = 89
pstr = "datum:         "
qstr = "Dr. " & TxtNaamD & "            " & TxtDoktersnummer
rstr = TxtStraatD & " " & TxtNummerD
With Range("B2")
.Value = pstr & Chr(10) & qstr & Chr(10) & rstr & Chr(10)
intp = WorksheetFunction.Search(pstr, Range("B2").Value)
intq = WorksheetFunction.Search(qstr, Range("B2").Value)
intr = WorksheetFunction.Search(rstr, Range("B2").Value)
.Characters(intp, Len(pstr)).Font.ColorIndex = 3
.Characters(intq, Len(qstr)).Font.ColorIndex = 5
.Characters(intr, Len(rstr)).Font.ColorIndex = 9
End With
End Sub
 
Je kunt het ook zonder Worksheetfunction doen:
Code: 
Sub test()
Dim txtZ As String
Dim iSt As Integer, iEnd As Integer, iFnt As Integer
Dim txt(7) As Variant, sK As Variant
Dim rng As Range

    txt(0) = InputBox("", "Naam")
    txt(1) = InputBox("", "Doktersnummer")
    txt(2) = InputBox("", "Straat")
    txt(3) = InputBox("", "Nummer")
    txt(4) = InputBox("", "Postcode")
    txt(5) = InputBox("", "Gemeente")
    txt(6) = InputBox("", "TelefoonnummerD")
    txt(7) = InputBox("", "Rizivnummer")

    Set rng = Range("B5")
    With rng
        .Value = "datum: " & Date & vbCrLf _
            & "Dr. " & txt(0) & ", " & txt(1) & vbCrLf _
            & txt(2) & " " & txt(3) & vbCrLf _
            & txt(4) & " " & txt(5) & vbCrLf _
            & "Tel: " & txt(6) & " --- " & "Rizivnr: " & txt(7) & vbCrLf _
            & "verklaart dat voor de aangevraagde testen met $ aan de diagnoseregel is voldaan"
        .Font.Color = RGB(0, 0, 0)
        .Font.Size = 8
        For i = 0 To 7
            iSt = InStr(1, txt(i), .Value)
            iEnd = Len(txt(i))
            iSt = InStr(1, .Text, txt(i))
            Select Case i
                Case 0, 2, 3, 5
                    sK = "RGB(255, 0, 0)"
                    sK = RGB(255, 0, 0)
                    iFnt = 9
                Case 2, 4, 6
                    sK = RGB(0, 255, 0)
                    iFnt = 7
                Case 1, 7
                    sK = RGB(0, 0, 255)
                    iFnt = 10
            End Select
            .Characters(Start:=iSt, Length:=iEnd).Font.Color = sK
            .Characters(Start:=iSt, Length:=iEnd).Font.Size = iFnt
        Next i
    End With
End Sub
Ook maar even een eigen variant gemaakt omdat er geen voorbeeldje is :).
 
Beste Zapatr en OctaFish,
Bedankt voor jullie reactie.
Duur de drukte op het werk heb ik nog niet echt verder kunnen doen.
Ik probeer morgen verder te bouwen op jullie reactie in de hoop dat ik iets werkend te krijgen.
Ik zal mijn resultaten posten.

Met vriendelijke groeten.
 
Ik heb beide voorbeelden verder uitgewerkt en ze werken beiden zoals ik wou.
Dit is hetgeen ik er van gemaakt heb:

Code: 
Dim txtZ As String
Dim iSt As Integer, iEnd As Integer, iFnt As Integer
Dim txt(7) As Variant, sK As Variant

Dim rng As Range

   txt(0) = TxtNaamD
    txt(1) = TxtDoktersnummer
    txt(2) = TxtStraatD
    txt(3) = TxtNummerD
    txt(4) = TxtPostcodeD
    txt(5) = TxtGemeenteD
    txt(6) = TxtTelefoonnummerD
    txt(7) = TxtRizivnummer
    
    Set rng = Range("B57")
    With rng
        .Value = "Voorschriftdatum: " & Date & "                              " & txt(1) & vbCrLf _
            & "Dr. " & txt(0) & ", " & vbCrLf _
            & txt(2) & " " & txt(3) & " - " & txt(4) & " " & txt(5) & vbCrLf _
            & "Tel: " & txt(6) & " --- " & "Rizivnr: " & txt(7) & vbCrLf _
            & "verklaart dat de aangevraagde testen met " & ChrW(&H270F) & " aan de diagnoseregel is voldaan"
        .Font.Color = RGB(0, 0, 0) 'zwart
        .Font.Size = 8
        For i = 0 To 7
            iSt = InStr(1, txt(i), .Value)
            iEnd = Len(txt(i))
            iSt = InStr(1, .Text, txt(i))
            Select Case i
                Case 0, 2, 3, 4, 5, 6, 7
                    sK = RGB(0, 0, 0)
                    iFnt = 8
                
                Case 1
                    sK = RGB(0, 0, 0)
                    iFnt = 14
                                    
            End Select
            .Characters(Start:=iSt, Length:=iEnd).Font.Color = sK
            .Characters(Start:=iSt, Length:=iEnd).Font.Size = iFnt
                       
        Next i
    End With

Code: 
Dim ostr As String, pstr As String, qstr As String, rstr As String, sstr As String, tstr As String
Dim intp As Integer, qint As Integer, rint As Integer


ostr = "Voorschriftdatum: " & Date & "                   "
pstr = TxtDoktersnummer
qstr = "Dr. " & TxtNaamD
rstr = TxtStraatD & " " & TxtNummerD & " - " & TxtPostcodeD & " " & TxtGemeenteD
sstr = "Tel: " & TxtTelefoonnummerD & " --- " & "Rizivnr: " & TxtRizivnummer
tstr = "verklaart dat de aangevraagde testen met " & ChrW(&H270F) & " aan de diagnoseregel is voldaan"
With Range("B57")
.Value = ostr & pstr & Chr(10) & qstr & Chr(10) & rstr & Chr(10) & sstr & Chr(10) & tstr
into = WorksheetFunction.Search(ostr, Range("B57").Value)
intp = WorksheetFunction.Search(pstr, Range("B57").Value)
intq = WorksheetFunction.Search(qstr, Range("B57").Value)
intr = WorksheetFunction.Search(rstr, Range("B57").Value)
ints = WorksheetFunction.Search(sstr, Range("B57").Value)
intt = WorksheetFunction.Search(tstr, Range("B57").Value)
.Characters(into, Len(ostr)).Font.Size = 8
.Characters(intp, Len(pstr)).Font.Size = 14
.Characters(intp, Len(pstr)).Font.Bold = True
.Characters(intq, Len(qstr)).Font.Size = 8
.Characters(intr, Len(rstr)).Font.Size = 8
.Characters(ints, Len(sstr)).Font.Size = 8
.Characters(intt, Len(tstr)).Font.Size = 7
End With
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan