VBA automatisk arknavn

Jeg leder efter en VBA function der kan ændre mine arknavn til A1.

Jeg er nået frem til:

Sub RenameFromA1()
Dim Msg As String, i As Integer
For i = 1 To Sheets.Count
If Sheets(i).Range("A1").Value = "" Then
Msg = "Sheet " & i & "(" & Sheets(i).Name & ") has no value in A1. Fix sheet, then rerun."
MsgBox Msg, vbExclamation
Exit Sub
Else
On Error GoTo ErrSheetName
Sheets(i).Name = Sheets(i).Range("A1").Value
On Error GoTo 0
End If
Next i
Exit Sub
ErrSheetName: Msg = "Sheet " & i & "(" & Sheets(i).Name & ") could not be renamed. Check if name already used."
MsgBox Msg, vbExclamation

End Sub

Jeg vil dog gerne have lavet den om til kun at tage de første 6 bogstaver fra A1?

På forhånd tak