Option Explicit
 
Const LCharsClear = 3   [color=green]' Anzahl der Zeichen die links 
' abgeschnitten werden sollen
Const RCharsClear = 3   [color=green]' Anzahl der Zeichen die rechts 
' abgeschnitten werden sollen
 
Const Col = 1           [color=green]' die Spalte die den anzupassenden Text 
' enthält
Const RowStart = 1      [color=green]' die 1. anzupassende Zeile
[hr]
 
' passt den Text auf dem aktuellen Blatt an
Public Sub TextAnpassen()
 
  Dim L As Long, Str As String
 
  [color=green]' die erste Zeile festlegen
  L = RowStart
 
  [color=green]' läuft, bis 1.Zelle einer Zeile keinen Inhalt hat
  While ActiveSheet.Cells(L, Col) <> ""
 
    Str = ActiveSheet.Cells(L, Col)
 
    [color=green]' wenn Len(Str) - RCharsClear < 0 ist, erzeugt dies
         ' Ausdruck ein Fehler in LEFT, hiermit wird's abgefangen
    If Len(Str) < RCharsClear Then
 
      [color=green]' wenn mehr weggeschnittel werden soll als da ist,
              ' bleibt nix übrig
      Str = ""
 
    Else
 
      [color=green]' hier wird der Text zurechtgeschnitten
      Str = Mid(Left(Str, Len(Str) - RCharsClear), _
        LCharsClear + 1)
 
    End If
 
    [color=green]' und den Text wieder zurückschreiben
    ActiveSheet.Cells(L, Col) = Str
 
    [color=green]' die nächste Zeile
    L = L + 1
 
  Wend
 
End Sub

Viel Spass,
R@lf