Problème d'initialisation de tri de cellules

Version imprimable

3 pièce(s) jointe(s)

Bonjour à vous,

(encore moi je sais ...)

J'ai un problème sur mon tri de cellule, il fonctionne mais il démarre mal et je ne comprends pas pourquoi...
Je vous explique la situation, il s'agit d'une application calculant à partir des données insérées par l'utilisateur des longueurs et etc... Ici en l’occurrence, l'utilisateur lambda insère son fichier .obj et ma procédure traite ce fichier .obj en dissociant les valeurs et etc... Ce que je cherche à faire, c'est isoler les premières valeurs associées à la ligne de "f", je vous explique en images si vous le permettez :

A la base le fichier ressemble à ça :
Pièce jointe 141438

Ensuite grâce à une procédure (que je vous présente après), il ressort comme ça :

Pièce jointe 141439

Comme vous pouvez le voir, il apparaît 2 fois la ligne (sur le screenshot), en réalité il apparaît 5 fois... Et de plus quand les valeurs changent (quand ce n'est plus 1 2 3 4), j'ai des lignes de "f" qui sont passées à la trappe :weird: ... Et après ça, ça reprend normal, mais il y a un décalage au niveau de la 4ème valeur associée à "f"

Voici ma procédure :

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
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
 
Sub test()
'
'
' only obj file from sketchup
'
'
 
Worksheets.Add
Worksheets(1).Activate
 
Dim strTemp As String
Dim MyDataObject As DataObject  
 
Dim i, j As Integer
Dim face As String
Dim TextPart As String
 
Dim FileName As Variant
 
 '
 ' import obj file
 '
 
  FileName = Application.GetOpenFilename("OBJ File (*.obj),*.obj,", 1, "Select an obj file from SketchUp to Import")
 
             Open FileName For Binary As #1
 
        If FileName = False Then
            MsgBox ("No file was selected.")
        Else
            ans = MsgBox("You selected and Obj file from SketchUp : " & FileName _
            & "                                                                                                      Continue ?", vbOKCancel)
                If ans = vbOK Then GoTo NextStep
                If ans = vbCancel Then Exit Sub              
        End If
 
NextStep:
 
 
    strTemp = Space$(LOF(1))
    Get #1, , strTemp
 
    strTemp = Replace(strTemp, " ", vbTab)
 
    Set MyDataObject = New DataObject
    MyDataObject.SetText strTemp
    MyDataObject.PutInClipboard
    Range("A1").PasteSpecial
 
    Close #1
 
    MyDataObject.Clear
    Set MyDataObject = Nothing
 
                        '
                        ' adaptation obj file - extracting face
                        '   
 
                      lastline = Range("A65536").End(xlUp).Row
 
                    Do While ActiveCell.Row < lastline + 1
 
                        If ActiveCell.Value = "f" Then
 
                            For j = 1 To 4
 
                                If ActiveCell.Offset(0, j) <> Empty Then
 
                                        face = ActiveCell.Offset(0, j).Value
                                        TextPart = ""
 
                                        For i = 1 To Len(face)
                                            If IsNumeric(Mid(face, i, 1)) Then
                                                TextPart = TextPart & Mid(face, i, 1)
                                            Else
                                                Exit For
                                            End If
                                        Next i
 
                                    ActiveCell.Offset(0, j).Value = TextPart
 
                                End If
                            Next j
                          End If
 
                        ActiveCell.Offset(1, 0).Select
                       Loop
 
  Cells.NumberFormat = "@"      'passage en format général car Excel est par défaut en mode date et c'est le bordel...
 
End Sub

Veuillez trouver ci-joint le fichier .obj en question.
Pièce jointe 141440

Quelqu'un aurait une solution à cette erreur ? Je soupçonne que le format "date" est complice dans cette affaire, faudrait il que je fasse le tri tant que je suis dans le clipboard ? Si oui, comment ?

Merci à vous

NB : Je remercie parmi pour le code qui permet de séparer les cellules.

Bonjour
Pouvez vous me donner les valeurs attendues en A22,B22,C22....
Puis en A28,b28....
Je comprend pas ce que vous voulez extraire de la string 'face' avec cette partie de code.

Code:

1
2
3
4
5
6
7
For i = 1 To Len(face)
                    If IsNumeric(Mid(face, i, 1)) Then
                    TextPart = TextPart & Mid(face, i, 1)
                    Else
                    Exit For
                    End If
                Next i

27/03/2014, 11h33
lemisentrope

Bonjour,

Oui pardon merci, j'ai oublié de le préciser, ce que je voudrais c'est que pour chaque ligne de f, garder que les premières valeurs avant les slashs : par exemple :

avant traitement :

A B C D E

f : 42/17/30 60/10/21 109/17/15 4/108/3

Après traitement :

f 42 60 109 4

C'est pourquoi j'utilise la commande IsNumeric car ce premier nombre peut aller de 1 à xxxxxxxx (x étant un chiffre).

Le problème est, je pense le formatage automatique des cellules d'Excel... Par exemple quand mes cellules ressemblent à des dates genre 5/1/4, il essaye à tout prix de me les convertir.... Cela doit être pour ça que mes premières lignes se ressemblent; cependant cela n'explique pas mon problème de décalage par la suite.

Merci de votre réponse :)

Bonjour

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
Sub test()
'je ne me suis ,volontairement, occupé que de la partie extraction pour coller le resultat en colonne F, a vous d'adapter.
Dim i As Integer, j As Integer
Dim face As String
Dim TextPart As String
Dim r As Range
'je ne balaie que les lignes de la colone A contenant "f"
derligne = Range("b65536").End(xlUp).Row
With Range("a1:a" & derligne)
    Set r = .Find("f", LookIn:=xlValues)
    If Not r Is Nothing Then
        firstAddress = r.Address
        Do
            For j = 1 To 4
                If r.Offset(0, j) <> Empty Then
                face = r.Offset(0, j).Value
 
                'recherche de la position du premier slash
                'et recuperation de tous les chiffres a gauche de cette position
                TextPart = TextPart & " " & Left(face, InStr(1, face, "/") - 1)
 
            End If
            Next j
            r.Offset(0, 5).Value = TextPart
            TextPart = ""
            Set r = .FindNext(r)
        Loop While Not r Is Nothing And r.Address <> firstAddress
    End If
End With
 
End Sub

Toute la partie de code en dessous de '
' adaptation obj file - extracting face
est à remplacer par celle ci dessus.

27/03/2014, 13h37
lemisentrope

Merci pour votre réponse mon problème de décalage est résolu cependant j'ai toujours les mêmes problèmes avec mes premières lignes. J'ai toujours 5 lignes de :

f 1 2 3 4

f 1 2 3 4

f 1 2 3 4

f 1 2 3 4

f 1 2 3 4

f 13 12 3 4

(la suite.....)

Au lieu de :

f 1 2 3 4

f 5 6 2 1

f 7 8 6 5

f 9 10 8 7

f 11 12 10 9

f 13 14 12 11
(la suite ..)

Auriez vous un format de cellule par défaut différent ?
Il doit s'agir d'un problème de format; j'ai analysé un bon nombre de lignes (en comparant avec mon fichier .obj) et j'ai remarqué que excel interprète une cellule comme : dd/mm/yy quand dans ma cellule du style : m/n/o ( m,n,o étant 3entiers relatifs) il y a n =< 12
De ce fait il modifie automatique l'ordre de "dd/mm" et donc la procédure (filtrant seulement les premières valeurs) est bernée.

Je ne vois pas comment contourner ce problème... Serait il possible d'utiliser une adaptation de votre code dans le clipboard ?
27/03/2014, 14h26
keygen08

Cela doit provenir de la methode d'importation des données, je ne me suis pas intérréssé a la premiere partie du code puisque non-fonctionnelle chez moi. J'avais donc telecharger le .obj avant de le transformer en .txt et ensuite l'importer dans excel.

la macro plante dés Dim MyDataObject As DataObject, je pense qu'il me faut activer une reference mais ne trouve pas laquelle.

En revanche, je vous propose ceci pour importer les données, puis recuperer les 4 premiers chiffres dans la colonne F.
Un peu rouillé en anglais mais j'aurais plutôt ecris ceci : You have selected an Obj file from SketchUp

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
50
Sub test()
'Se placer sur une feuille vierge avant d'executer la macro
Dim i As Integer, j As Integer, dl As Integer
Dim face As String
Dim TextPart As String
Dim FileName As Variant
 
  FileName = Application.GetOpenFilename("OBJ File (*.obj),*.obj,", 1, "Select an obj file from SketchUp to Import")
             Open FileName For Binary As #1
        If FileName = False Then
            MsgBox ("No file was selected.")
        Else
            ans = MsgBox("You selected and Obj file from SketchUp : " & FileName _
            & "                                                                                                      Continue ?", vbOKCancel)
                If ans = vbOK Then GoTo nextstep
                If ans = vbCancel Then Exit Sub
        End If
nextstep:
'importation des données dans la feuile excel
Do While Not EOF(1)
    Line Input #1, strLigne
    t = Split(strLigne, " ")
        On Error Resume Next
        dl = ActiveSheet.[a65000].End(xlUp).Row + 1
        If UBound(t) = -1 Then ActiveSheet.Cells(dl, 1) = "'"
        ActiveSheet.Cells(dl, 1).Resize(1, UBound(t) + 1) = t
Loop
Close #1
 
derligne = Range("b65536").End(xlUp).Row
With Range("a1:a" & derligne)
    Set r = .Find("f", LookIn:=xlValues)
    If Not r Is Nothing Then
        firstAddress = r.Address
        Do
            For j = 1 To 4
                If r.Offset(0, j) <> Empty Then
                face = r.Offset(0, j).Value
                TextPart = TextPart & " " & Left(face, InStr(1, face, "/") - 1)
 
            End If
            Next j
            r.Offset(0, 5).Value = TextPart
            TextPart = ""
            Set r = .FindNext(r)
        Loop While Not r Is Nothing And r.Address <> firstAddress
    End If
End With
 
End Sub

27/03/2014, 22h27
lemisentrope

Tout d'abord merci de vos réponses,

J'avais eu aussi un problème lorsque "parmi" m'avait proposé cette procédure, puis j'avais essayé dans mon Userform et ça avait fonctionné, et du coup après j'ai réessayé en mode normal (en lançant la macro direct) et ça a marché.

Je vous remercie pour cette procédure, ça fonctionne nickel, j'essaye de comprendre certains passage - surtout la ligne 26 :weird:

Ah oui effectivement j'avais pas fait attention à l'anglais, merci :)

Merci beaucoup ! :)