tekst inkorten

[spokkem]

Hallo

ik ben bezig met een sticker uitdraai te maken.
het is me tot zover gelukt alleen de tekst die in blad sticker op b2 komt te staan is soms te lang.
ik ben al bezig geweest met links maar krijg op een of andere manier het niet voor elkaar hij blijft foutmeldingen geven.
de tekst zou ik ook in kunnen korten zijnde het niet dat dit gekopieerd wordt uit een bestand en om dan alle teksten aan te passen is te veel werk.
hieronder de routine

vr gr Spokkem

Sub tst()
Dim eenheid As String
Dim response As Integer
eenheid = ("gegevens")
Set tSheet = Sheets("sticker")
Application.EnableEvents = False
Application.ScreenUpdating = False


With Sheets(eenheid)
For Each cl In .Range("a2:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
sq = .Cells(cl.Row, 1).Resize(, 3)
With tSheet
.Range("b1").Value = sq(1, 1)
.Range("b2").Value = sq(1, 2) deze regel mag maar 15 letter bevatten zodat het op de sticker past.
.Range("b3").Value = sq(1, 3)
End With
tSheet.PrintPreview '.PrintOut Copies:=2 '.PrintPreview '.PrintOut Copies:=2
Next
End With

Range("b1") = ""
Range("b2") = ""
Range("b3") = ""
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

 

[alphamax]

.Range("b2").Value = [COLOR="#FF0000"]Left([/COLOR]sq(1, 2)[COLOR="#FF0000"], 15)[/COLOR]

 

[spokkem]

alphamax

bedankt werkt uitstekent je moet dus left gebruiken ipv links.

vr gr Spokkem

 

[VenA]

of zo

Sub VenA()
  Dim j As Long, ar
  ar = Sheets("gegevens").Cells(1).CurrentRegion
  With Sheets("sticker")
    For j = 2 To UBound(ar)
      .Cells(1, 2).Resize(3) = Application.Transpose(Array(ar(j, 1), Left(ar(j, 2), 15), ar(j, 3)))
      .PrintPreview
    Next j
    .Cells(1, 2).Resize(3).ClearContents
  End With
End Sub

 

[spokkem]

dank je wel VenA
een stuk korter ga ik toepassen.

vr gr Spokkem