Split Cell + Add Formulas

Version imprimable

1 pièce(s) jointe(s)

Bonjour

Je travaille sur un code permettant l'extraction (le split) des donnees d'un champs. Le code fonctionne mais il y a certaines erreurs que je n'arrive a corriger.
LE fichier excel est construit comme cela:
- Feuille 'Input' comprenant en colonne C 'Basic Data' le champs que je souhaite extraire + 2 boutons (Macro pour generer, et Clean pour retirer les donnees)
- Feuille 'Output' Colonne A --> Material reference, Col B --> Sequence Nb, Col C --> Les champs splittes
- Feuille 'Back-up' --> Feuille cree manuellement qui reprend les informations de la feuille 'Output' et a laquelle je souhaite ajouter 3 formules automatiquement via le code sur le la feuille 'Output'

Pour resumer,
Le code fonctionne pour le split --> Cependant, cela genere a partir de la premiere ligne (les en-tete) de la feuille 'Input'. Dans l'ideal, generer a partir de la seconde ligne
Qund le code genere, il y a des infos en colonne D de la feuille Input qui se cree, j'aimerais que ces donnees n apparaissent pas
Les 3 formules ne sont pas operationnelles via le VBA (exemple dans le code ou formules excel de la feuille Back-Up)
Et si on peut en meme temps ameliorer la mise en page (column Width) pour ajuster la longueur des colonnes, ce serait parfait.

Merci pour votre aide
Pièce jointe 632214

Voici le code a l instant t
Code:

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 Sub Split_Cell() Dim nbcar_init, nbcar_end, Nb_int, Nb_space, j, k, a, b, z, y, r As Long Dim i As Long Dim cell_interm As String LastRow = ThisWorkbook.Sheets("Output").Cells(Rows.Count, 2).End(xlUp).Row j = 1 k = 0 a = 1 z = 1 y = 10 r = 2 While Cells(a, 3) <> "" Cells(a, 4) = Cells(a, 3) & Chr(10) a = a + 1 Wend 'Columns("C:C").Delete Shift:=xlToLeft ThisWorkbook.Sheets("Output").Range("A1:E" & LastRow).ClearContents While Cells(j, 3) <> "" nbcar_init = Len(Cells(j, 3)) ' BASIC DATA nbcar_end = Len(Replace(Cells(j, 3), Chr(10), "")) Nb_space = (nbcar_init - nbcar_end) cell_interm = Cells(j, 3) i = 2 For i = (1 + k) To (Nb_space + k) Sheets("Output").Cells(i, 1) = Sheets("Input").Cells(z, 1) ' Column 1 Sheets("Output").Cells(i, 2) = y 'Column 2 Sheets("Output").Cells(i, 3) = Left(cell_interm, InStr(1, cell_interm, Chr(10))) 'Column 3 Nb_int = Len(cell_interm) - InStr(1, cell_interm, Chr(10)) cell_interm = Right(cell_interm, Nb_int) y = y + 10 'ICI 'Sheets("Output").Cells(i, 4).Formula = "=RIGHT(RC[-2],LEN(RC[-2])-SEARCH("":"",RC[-2],1))" 'COLONNE E 'Sheets("Output").Cells(i, 5).Formula = "=TRIM(RC[-1])" 'COLONNE F 'Sheets("Output").Cells(i, 6).Formula = "=RC[-6]&""/""&RC[-5]" 'COLONNE G Next j = j + 1 k = k + Nb_space z = z + 1 y = 10 i = i + 1 Wend 'Columns("C:C").Delete Shift:=xlToLeft End Sub

1 pièce(s) jointe(s)

Bonjour,

Un début de solution, à adapter, utilisant la fonction Split() pour obtenir chacune des lignes:

Code:

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
Option Explicit
 
Sub CleanUpColumnC()
    Dim kR As Long, s As String
    ThisWorkbook.Worksheets("Input").Select
    kR = 1
    While Cells(kR, 1) <> ""
        s = Trim(Cells(kR, 3))              '--- supprime les espaces devant et derrière
        s = Replace(s, vbLf & vbLf, "")     '--- supprime les doubles sauts de ligne
        If Asc(Right(s, 1)) = 10 Then
            s = Left(s, Len(s) - 1)         '--- supprime le dernier saut de ligne
        End If
        If Asc(Left(s, 1)) = 10 Then
            s = Mid(s, 2)                   '--- supprime le premier saut de ligne
        End If
        Cells(kR, 3) = s
        kR = kR + 1
    Wend
End Sub
 
Sub Split_Cell()
    Dim kRi As Long, kRo As Long, arrBD() As String, i As Long, k As Long
    CleanUpColumnC
    ThisWorkbook.Sheets("Output").Cells.ClearContents       '--- Clear Output
    ThisWorkbook.Worksheets("Input").Select
    kRi = 2
    kRo = 2
    With ThisWorkbook.Worksheets("Output")
        While Cells(kRi, 1) <> ""
            arrBD = Split(Cells(kRi, 3), vbLf)              '--- split
            For i = 0 To UBound(arrBD)
                .Cells(kRo, 1) = Cells(kRi, 1)
                .Cells(kRo, 2) = 10 * (i + 1)
                .Cells(kRo, 3) = arrBD(i)
                k = InStr(arrBD(i), ":")
                .Cells(kRo, 4) = Left(arrBD(i), k - 1)
                .Cells(kRo, 5) = Trim(Mid(arrBD(i), k + 1))
                .Cells(kRo, 6) = .Cells(kRo, 1) & "/" & .Cells(kRo, 2)
                kRo = kRo + 1
            Next i
            kRi = kRi + 1
        Wend
    End With
End Sub

Cordialement.

Merci, c'est Parfait Eric!!!!

Citation:

Envoyé par EricDgn

Bonjour,

Un début de solution, à adapter, utilisant la fonction Split() pour obtenir chacune des lignes:

Code:

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
Option Explicit
 
Sub CleanUpColumnC()
    Dim kR As Long, s As String
    ThisWorkbook.Worksheets("Input").Select
    kR = 1
    While Cells(kR, 1) <> ""
        s = Trim(Cells(kR, 3))              '--- supprime les espaces devant et derrière
        s = Replace(s, vbLf & vbLf, "")     '--- supprime les doubles sauts de ligne
        If Asc(Right(s, 1)) = 10 Then
            s = Left(s, Len(s) - 1)         '--- supprime le dernier saut de ligne
        End If
        If Asc(Left(s, 1)) = 10 Then
            s = Mid(s, 2)                   '--- supprime le premier saut de ligne
        End If
        Cells(kR, 3) = s
        kR = kR + 1
    Wend
End Sub
 
Sub Split_Cell()
    Dim kRi As Long, kRo As Long, arrBD() As String, i As Long, k As Long
    CleanUpColumnC
    ThisWorkbook.Sheets("Output").Cells.ClearContents       '--- Clear Output
    ThisWorkbook.Worksheets("Input").Select
    kRi = 2
    kRo = 2
    With ThisWorkbook.Worksheets("Output")
        While Cells(kRi, 1) <> ""
            arrBD = Split(Cells(kRi, 3), vbLf)              '--- split
            For i = 0 To UBound(arrBD)
                .Cells(kRo, 1) = Cells(kRi, 1)
                .Cells(kRo, 2) = 10 * (i + 1)
                .Cells(kRo, 3) = arrBD(i)
                k = InStr(arrBD(i), ":")
                .Cells(kRo, 4) = Left(arrBD(i), k - 1)
                .Cells(kRo, 5) = Trim(Mid(arrBD(i), k + 1))
                .Cells(kRo, 6) = .Cells(kRo, 1) & "/" & .Cells(kRo, 2)
                kRo = kRo + 1
            Next i
            kRi = kRi + 1
        Wend
    End With
End Sub

Cordialement.