Formatage chaine caracteres aprés extraction d'un fichier

Bonjour

Dans le sub genere - je voudrai extraire une chaine de 50 caractères de la cellule B de la ligne Fourn et l'ecrire dans le nouveau fichier. Que faire?

Merci d'avance

'Génère un fichier contenant toutes les fournitures renseignées 
Public Sub Genere() 

Dim fourn() As String 
Dim NomFich As String 
Dim Chemin As String 

    'Récupèration des fournitures 
    fourn = RecupFourn 

    'Récupère le nom du fichier 
    NomFich = Range("Fichier") 

    If NomFich = "" Then 
        MsgBox "Saisir le nom du fichier à créer" 
        Exit Sub 
    End If 

    'Créer le chemin du nouveau fichier (même endroit que le fichier actuel) 
    Chemin = ThisWorkbook.Path & "\" & NomFich & ".xls" 

    'Crée un nouveau fichier Excel 
    CreerFich 

    'Transfère les données dans le fichier 
     With Sheets("Commande") 

      .Range("A1", "D" & CStr(UBound(fourn, 2) + 1)) = Application.WorksheetFunction.Transpose(fourn) 

        .Range("E1") = "Observation" 
        .Range("F1") = "Type" 

     End With 

    MiseEnForme 

    ActiveWorkbook.SaveAs Filename:=Chemin, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False 
 '   ActiveWorkbook.Close 

End Sub 

'Récupère les lignes dont les quantités ont été renseignées 
Private Function RecupFourn() As String() 

Dim i As Integer 
Dim Ligne() As String 

    ReDim Preserve Ligne(3, 100) 
    i = 0 
    'Récupère les lignes avec des quantités 
    For Each cel In Range("Quantite") 
        If cel.Value <> "" Then 
            Ligne(0, i) = cel.Offset(0, -2) 
            Ligne(1, i) = cel.Offset(0, -1) 
            Ligne(2, i) = cel 
            Ligne(3, i) = cel.Offset(0, 1) 
            i = i + 1 
        End If 
    Next cel 
    ReDim Preserve Ligne(3, i - 1) 

    RecupFourn = Ligne 

End Function 

'Efface toutes les quantités 
Public Sub EffaceQté() 

    If MsgBox("Voulez-vous supprimer toutes les quantités ?", vbYesNo, "Avertissement") = vbYes Then 
        For Each cel In Range("Quantite") 
            If cel.Value <> "Qté" Then 
                cel.Value = "" 
            End If 
        Next cel 
    End If 

End Sub 

'Création du nouveau fichier 
Private Sub CreerFich() 

    'Crée un nouveau fichier Excel 
    Workbooks.Add 
    Sheets("feuil1").Name = "Commande" 
    Application.DisplayAlerts = False 
   ' Sheets("Feuil2").Delete (les 2 lignes genere un problème "erreur 9 cette sélection n'appartien ppas à l'indice" 
   ' Sheets("Feuil3").Delete 
    Application.DisplayAlerts = True 

End Sub 

'Mise en forme du fichier 
Private Sub MiseEnForme() 

    'Mise en forme des données 
    Sheets("Commande").Range("A1", "F1").CurrentRegion.Select 
    With Selection 

        .Borders.LineStyle = xlContinuous 
        .HorizontalAlignment = xlCenter 
        .VerticalAlignment = xlCenter 
        .Font.Name = "arial" 
        .Font.ColorIndex = 0 
        .Font.Size = 10 
        .Columns(1).ColumnWidth = 24 
        .Columns(2).ColumnWidth = 50 
        .Columns(2).HorizontalAlignment = xlLeft 
        .Columns(3).ColumnWidth = 10 
        .Columns(4).ColumnWidth = 35 
        .Columns(5).ColumnWidth = 16 
        .Columns(6).ColumnWidth = 8 
        ' .EntireColumn.AutoFit 
    End With 
    'Mise en forme des titres 
    Sheets("Commande").Range("A1", "F1").Select 
    With Selection 
        .Font.FontStyle = "Gras" 
        .Interior.ColorIndex = 9 
        .Font.ColorIndex = 2 
        .Font.Size = 12 
        .Columns(2).HorizontalAlignment = xlCenter 
      ' .EntireColumn.AutoFit 
   End With 
End Sub 
Sub Début() 
     Range("Début").Select 
End Sub

Bonjour et bienvenue sur le forum

En joignant ton fichier, il serait plus facile de t'aider.

Bye !

Bonjour,

une solution à l'aveugle, à tester

'Génère un fichier contenant toutes les fournitures renseignées
Public Sub Genere()

Dim fourn() As String
Dim NomFich As String
Dim Chemin As String

'Récupèration des fournitures
fourn = RecupFourn

'Récupère le nom du fichier
NomFich = Range("Fichier")

If NomFich = "" Then
MsgBox "Saisir le nom du fichier à créer"
Exit Sub
End If

'Créer le chemin du nouveau fichier (même endroit que le fichier actuel)
Chemin = ThisWorkbook.Path & "\" & NomFich & ".xls"

'Crée un nouveau fichier Excel
CreerFich

'Transfère les données dans le fichier
With Sheets("Commande")

.Range("A1", "D" & CStr(UBound(fourn, 2) + 1)) = Application.WorksheetFunction.Transpose(fourn)
For i = 2 To UBound(fourn, 2) + 1
.Range("B" & i) = Left(.Range("B" & i), 50) ' prendre 50 premiers caractères de la colonne B
Next i
.Range("E1") = "Observation"
.Range("F1") = "Type"

End With

Merci

Le problème est résolu avec le bout de code que vous m'avez passé.

bonne journée

84mike a écrit :

Merci

Le problème est résolu avec le bout de code que vous m'avez passé.

bonne journée

Bonjour,

n'oublie pas de mettre le problème comme résolu.