Discussion :

[micol84]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
'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

[Marc-L]

Déjà résolu sur un autre forum …