Discussion :

[Leehan]

Bonjour,

Dans le tableau excel en piece jointe, je travaille sur 4 colonnes :

id
Angle2
TolM
TolP

Angle2 est le gisement de chaque polyligne en degrés.
TolM et TolP sont deux mesures d'angle qui définissent l'angle perpendiculaire à Angle2...avec une Tolerance de x% en Moins et en Plus.

Je cherche tous les angles qui font + ou - 90° pour chaque valeur d'angle2.
Autrement dit, je cherche un moyen "automatique" qui permette de :

• considerer une valeur d'Angle2;

• Determiner quels sont les autres enregistrements pour lesquels l('eur) angle2 est compris entre le Tolm et TolP de l'angle considéré;

• Creer un beau tableau avec pour chaque id et donc chaque angle2, les ids de tous les autres enregistrements qui satisfont le critere c a d les ids de tous les autres enregistrements dont l'orientation est plus ou moins perpendiculaires (à n% près) à chaque angle2.

EXemple :

Code :

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

1
2
3
4
5
 
id Angle2 TolM TolP 
324 76,04 159,4 172,7 
323 164,01 243,85 264,17 
322 96.13  178,69 193,5

le resultat cherché est :

Code :

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

1
2
3
 
id Angle2 id' Angle2' 
324 76,04 323 164,01

car l'angle2 164,01 (id = 323) est compris entre 159,4 et 172,7.

Je ne sais pas comment automatiser cela sous Excel.
je ne sais meme pas si c'est possible.
Qu'en pensez-vous ?

Merci

[mercatog]

Tu n'as pas spécifié sur ton fichier le tableau de sortie souhaité.
Sinon, un premier code

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
Sub Creation()
Dim i As Long, j As Long, n As Long
Dim Str As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n).CurrentRegion
    ReDim Res(1 To n, 1 To 5)
    Res(1, 1) = "ID_CENTER": Res(1, 2) = "Angle2": Res(1, 3) = "TolM": Res(1, 4) = "TolP": Res(1, 5) = "Resultat"
    For i = 2 To n
        Res(i, 1) = Tb(i, 2)
        Res(i, 2) = Tb(i, 6)
        Res(i, 3) = Tb(i, 9)
        Res(i, 4) = Tb(i, 9)
        For j = 2 To n
            If i <> j Then
                If Res(i, 2) >= Tb(j, 9) And Res(i, 2) <= Tb(j, 10) Then Str = Str & ", " & Tb(j, 2) & " (" & Tb(j, 6) & ")"
            End If
        Next j
        If Len(Str) > 0 Then Res(i, 5) = Mid(Str, 3)
        Str = ""
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(n, 5) = Res
End Sub

[Leehan]

ma deuxieme boite de code est un exemple de ce que je souhaite obtenir à partir d'un extrait de la premiere.
Il n'est pas suffisant ?

Ce que je souhaite :
pour chaque angle, c'est ne retenir que les autres qui appartiennent à l'intervalle (TolM;TolP)

id (id_center) Angle2 id' Angle2'

le premier id = l'id d'angle2 et sa valeur.
Les deux derniers (id' Angle2') sont les caracteristiques des angles dont l'angle2 appartient au susdit intervalle.


merci pour le code
erreur 400 que ca dit.
Le tableau ne comporte que 6 lignes, les 6 premieres su tableau initial.
La colonne resultat est vide.
Déjà, Id_Center n'est pas aussi utile que le Id tout court.

[mercatog]

Non ce n'est pas suffisant.

[Leehan]

arf trop rapide, j'étais en train d'éditer
mes explications sont elles plus claires ?

j'ai complété le tableau en piece jointe avec une feuille et un exemple du tableau resultat recherché.
Merci

[mercatog]

As tu testé le code précédent?
Sinon, code changé en indiquant seulement le id

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
Sub Creation()
Dim i As Long, j As Long, n As Long
Dim Str As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n).CurrentRegion
    ReDim Res(1 To n, 1 To 5)
    Res(1, 1) = "id": Res(1, 2) = "Angle2": Res(1, 3) = "TolM": Res(1, 4) = "TolP": Res(1, 5) = "Resultat"
    For i = 2 To n
        Res(i, 1) = Tb(i, 1)
        Res(i, 2) = Tb(i, 6)
        Res(i, 3) = Tb(i, 9)
        Res(i, 4) = Tb(i, 9)
        For j = 2 To n
            If i <> j Then
                If Res(i, 2) >= Tb(j, 9) And Res(i, 2) <= Tb(j, 10) Then Str = Str & ", " & Tb(j, 1) & " (" & Tb(j, 6) & ")"
            End If
        Next j
        If Len(Str) > 0 Then Res(i, 5) = Mid(Str, 3)
        Str = ""
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(n, 5) = Res
End Sub

Pour chaque ligne du tableau initial, on concatène en colonne E les id dont l'Angle2 est compris entre TolM et TolP

[mercatog]

Autre proposition

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
Sub Creation2()
Dim i As Long, j As Long, n As Long, k As Long
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n).CurrentRegion
    ReDim Res(1 To 5, 1 To 1)
    Res(1, 1) = "id": Res(2, 1) = "Id_Center": Res(3, 1) = "Angle2": Res(4, 1) = "id": Res(5, 1) = "Angle2"
    k = 1
    For i = 2 To n
        For j = 2 To n
            If i <> j Then
                If Tb(i, 6) >= Tb(j, 9) And Tb(i, 6) <= Tb(j, 10) Then
                    k = k + 1
                    ReDim Preserve Res(1 To 5, 1 To k)
                    Res(1, k) = Tb(i, 1)
                    Res(2, k) = Tb(i, 2)
                    Res(3, k) = Tb(i, 6)
                    Res(4, k) = Tb(j, 1)
                    Res(5, k) = Tb(j, 6)
                End If
            End If
        Next j
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(k, 5) = Application.Transpose(Res)
End Sub

[Leehan]

J'ai testé le premier présent dans cette page oui. J y ai même mis un debriefing.

Je teste les deux ci-dessus asap et reviendrai sur le forum.

Merci de ton attention

[Leehan]

La premiere macro code donne "erreur 400".
La seconde macro donne un grand tableau mais je ne sais pas exatement à quoi il correspond ; en tout cas pas à ca que je cherche... : /

j'ai réalisé à la main le tableau ci-dessous en selectionnant pour l'id = 1 les angles compris entre 119,8965088 et 129,8878845 (TolM et TolP de id = 1)

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
 
id	Angle2	Id  ID_CENTER  Long2	Angle2
1	34,8922	623	1022	1,68	120,123
1	34,8922	215	659	1,01	120,611
1	34,8922	748	1074	1,9	120,858
1	34,8922	521	1003	2,15	122,328
1	34,8922	98	675	0,86	122,708
1	34,8922	108	675	0,86	122,708
1	34,8922	440	993	0,94	122,892
1	34,8922	11	655	2,26	123,339
1	34,8922	147	492	2,2	123,393
1	34,8922	545	1006	1,36	123,514
1	34,8922	773	1050	2,71	124,158
1	34,8922	27	667	1,23	125,464
1	34,8922	10	655	1,7	126,082
1	34,8922	739	1052	1,58	126,218
1	34,8922	364	684	3,83	126,401
1	34,8922	145	492	1,65	126,547
1	34,8922	283	669	1,8	126,688
1	34,8922	48	985	0,36	127,093
1	34,8922	374	960	0,36	127,182
1	34,8922	754	1076	1,59	128,664

C'est ceci que je desirerais automatiser car à la main id par id, ca ne va pas le faire
merci

[mercatog]

Code 1

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
Sub Creation2()
Dim i As Long, j As Long, n As Long, k As Long
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n)
    ReDim Res(1 To 6, 1 To 1)
    Res(1, 1) = "id": Res(2, 1) = "Angle2": Res(3, 1) = "id": Res(4, 1) = "ID_CENTER": Res(5, 1) = "Long2": Res(6, 1) = "Angle2"
    k = 1
    For i = 2 To n
        For j = 2 To n
            If i <> j Then
                If Tb(j, 6) >= Tb(i, 9) And Tb(j, 6) <= Tb(i, 10) Then
                    k = k + 1
                    ReDim Preserve Res(1 To 6, 1 To k)
                    Res(1, k) = Tb(i, 1)
                    Res(2, k) = Tb(i, 6)
                    Res(3, k) = Tb(j, 1)
                    Res(4, k) = Tb(j, 2)
                    Res(5, k) = Tb(j, 4)
                    Res(6, k) = Tb(j, 6)
                End If
            End If
        Next j
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(k, 6) = Application.Transpose(Res)
End Sub

Code 2: Le code 1 ne prends pas en compte les lignes où il n'y a pas correspondance (par exemple id 6). Pour pallier à cela:

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
Sub Creation3()
Dim i As Long, j As Long, n As Long, k As Long, t As Long
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n)
    ReDim Res(1 To 6, 1 To 1)
    Res(1, 1) = "id": Res(2, 1) = "Angle2": Res(3, 1) = "id": Res(4, 1) = "ID_CENTER": Res(5, 1) = "Long2": Res(6, 1) = "Angle2"
    k = 1
    For i = 2 To n
        For j = 2 To n
            If i <> j Then
                If Tb(j, 6) >= Tb(i, 9) And Tb(j, 6) <= Tb(i, 10) Then
                    t = t + 1
                    k = k + 1
                    ReDim Preserve Res(1 To 6, 1 To k)
                    Res(1, k) = Tb(i, 1)
                    Res(2, k) = Tb(i, 6)
                    Res(3, k) = Tb(j, 1)
                    Res(4, k) = Tb(j, 2)
                    Res(5, k) = Tb(j, 4)
                    Res(6, k) = Tb(j, 6)
                End If
            End If
        Next j
        If t = 0 Then
            k = k + 1
            ReDim Preserve Res(1 To 6, 1 To k)
            Res(1, k) = Tb(i, 1)
            Res(2, k) = Tb(i, 6)
        Else
            t = 0
        End If
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(k, 6) = Application.Transpose(Res)
End Sub

Sinon, Code 0 a été testé sur ton fichier sans aucune erreur

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
Sub Creation0()
Dim i As Long, j As Long, n As Long
Dim Str As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A1:J" & n).CurrentRegion
    ReDim Res(1 To n, 1 To 5)
    Res(1, 1) = "id": Res(1, 2) = "Angle2": Res(1, 3) = "TolM": Res(1, 4) = "TolP": Res(1, 5) = "Resultat"
    For i = 2 To n
        Res(i, 1) = Tb(i, 1)
        Res(i, 2) = Tb(i, 6)
        Res(i, 3) = Tb(i, 9)
        Res(i, 4) = Tb(i, 9)
        For j = 2 To n
            If i <> j Then
                If Tb(j, 6) >= Tb(i, 9) And Tb(j, 6) <= Tb(i, 10) Then Str = Str & ", " & Tb(j, 1) & " (" & Tb(j, 6) & ")"
            End If
        Next j
        If Len(Str) > 0 Then Res(i, 5) = Mid(Str, 3)
        Str = ""
    Next i
End With
ThisWorkbook.Worksheets.Add.Range("A1").Resize(n, 5) = Res
End Sub

Peut être il ne faudrait pas faire une simple copier/coller


EDIT
Pour ton erreur 400, ça pourrait venir de ceci (vu la version de ton Excel)
http://support.microsoft.com/kb/832136/fr

[Leehan]

la creation2 donne le résultat souhaité (code1)!
J'ai comparé avec exemples faits à la main pour id=1 et id=2 et ca correspond.

Merci bcp de ton aide

PS : j'abuse si je te demande de commenter le code de la creation2 histoire que je saisisse ce qui se passe vraiment ?

[mercatog]

Avec plaisir

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
Sub Creation3()
Dim i As Long, j As Long, n As Long, k As Long, t As Long
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    'n: nombre de lignes de données
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    'Tb: Variable tableau qui prends toutes les données de A1 à Jxx
    'Tb(i,j) est la donnée de la ligne i et colonne j
    'Exemple Tb(6,4) correspond à la donnée en D4
    Tb = .Range("A1:J" & n)
 
    'Res est notre tableau résultat escompté (avec 6 colonnes). Ce tableau est redimensionné dynamiquement car à priori on ne connait pas
    'le nombre de lignes qu'il va contenir.
    'Par rapport à Tb, Res est inversé (Car on ne peut redimensionner que la dernière dimension)
    'Si Tb avait une forme en 10 colonnes et n lignes, Res sera de 6 lignes et xxx colonnes
    'On dimensionne Res à 6x1 et on y écrit les titres
    ReDim Res(1 To 6, 1 To 1)
    Res(1, 1) = "id": Res(2, 1) = "Angle2": Res(3, 1) = "id": Res(4, 1) = "ID_CENTER": Res(5, 1) = "Long2": Res(6, 1) = "Angle2"
    k = 1
    'On boucle sur le tableau Tb (pour chaque id): variable i
    For i = 2 To n
        'On reboucle sur le tableau Tb et on compare l'Angle2 par rapport à TolM et TolP, variable j
        'Angle2 de la boucle en j correspond à Tb(j,6)
        'TolM et TolP de la boucle en i correspondent respectivement à Tb(i,9) et Tb(i,10)
        For j = 2 To n
            If i <> j Then
                If Tb(j, 6) >= Tb(i, 9) And Tb(j, 6) <= Tb(i, 10) Then
                    'Si Angle2 de j est compris entre TolM et TolP de i, alors on augmente k et t d'une unité
                    t = t + 1
                    k = k + 1
                    'On redimensionne le tableau Res et on y insère respectivement les données de la ligne trouvée
                    ReDim Preserve Res(1 To 6, 1 To k)
                    Res(1, k) = Tb(i, 1)
                    Res(2, k) = Tb(i, 6)
                    Res(3, k) = Tb(j, 1)
                    Res(4, k) = Tb(j, 2)
                    Res(5, k) = Tb(j, 4)
                    Res(6, k) = Tb(j, 6)
                End If
            End If
        Next j
        'Si on sort de la boucle en j sans trouver de lignes correspondant au critère (càd t=0)
        If t = 0 Then
            'On augmente k et on inscrit la donnée id et Angle2(exemple ligne 6 qui ne répond pas au critères)
            k = k + 1
            ReDim Preserve Res(1 To 6, 1 To k)
            Res(1, k) = Tb(i, 1)
            Res(2, k) = Tb(i, 6)
        Else
            t = 0
        End If
    Next i
End With
'on ajoute une feuille et on y inscrit le tableau Res (en transposé parce qu'on avait inversé Res pour le besoin de redimensionnement)
ThisWorkbook.Worksheets.Add.Range("A1").Resize(k, 6) = Application.Transpose(Res)
End Sub

[Leehan]

merci super !

tu as commenté la sub creation 3 alors que la 2 etait l'élue. Je n'ai vu que la variable t est en plus dans la 3. J'ai bon ?

[mercatog]

Un peu d'effort est nécessaire. Tu as tout ce que répond au sujet.

PS: Ici c'est un forum d'entraide de volontariat et non une boite à sous-traitance.

[Leehan]

oui bien sûr

je ne savais pas si tu l avais fait à dessein ou pas.
Sinon c'est parfait.
encore merci.