• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

tekst inkorten

Status
Niet open voor verdere reacties.

spokkem

Gebruiker
Lid geworden
28 feb 2008
Berichten
108
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
 

Bijlagen

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

bedankt werkt uitstekent je moet dus left gebruiken ipv links.

vr gr Spokkem
 
of zo
Code:
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
 
dank je wel VenA
een stuk korter ga ik toepassen.

vr gr Spokkem
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan