VBA pour extraire des données

Version imprimable

03/03/2020, 16h56
Caroline2020

1 pièce(s) jointe(s)

VBA pour extraire des données

Bonjour le Forum,

Je vous sollicite parce que je ne parvient pas à trier des valeurs et je ne suis pas experte en VBA!
J'ai un tableau "Data" avec différents matériaux ou l'on effectuent des tests journalièrement, sur chaque échantillon nous faisons 5 tests d'adhérence et chaque valeur est reportée dans le tableau.
Afin de pouvoir continuer la suite des tests je dois trouver les échantillons qui ont 1 ou plusieurs valeurs identique.
J'ai mis un exemple du résultat que je souhaiterai dans l'onglet bilan
A noter que les cases noires c'est parce qu'il n'y a pas de résultat (test qui n'a pas fonctionné), sur les échantillons il y a des matériaux qui ont des valeurs identiques, les valeurs recherchées doivent être comprises entre 6 et 10 (sur l'ensemble des 6 matériaux) afin de mettre ces échantillons en test de vieillissement.

Aussi je vais avoir environ 500 lignes à traiter, les échantillons qui auront les valeurs identiques seront testés ensemble en vieillissement, comme dans l'exemple les échantillons 5 et 10 les échantillons 1 et 8 et les échantillons 2, 6 et 11

Pièce jointe 542778

J'espère sincèrement que vous pourrez m'aider
Merci d'avance,

Caroline
06/03/2020, 17h20
EricDgn

1 pièce(s) jointe(s)

Bonjour,

Pas encore de solution, mais que faut-il faire si un échantillon a plusieurs semblables sur des valeurs différentes, comme dans cet exemple fictif pour l'échantillon n°5:
Pièce jointe 543681
Et quid si pour un même test il y a 2 résultats identiques (sans doute exceptionnel mais possible).
Cordialement.

1 pièce(s) jointe(s)

Bonjour,

Il est possible de faire cela avec une macro qui compare les valeurs ligne par ligne.
Une façon de faire:

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
Option Explicit
 
Sub Semblables()
    Dim kr1 As Long, kr2 As Long, kC1 As Long, kC2 As Long
    Dim kR As Long, kRfin As Long
    Dim v As Variant, nIdem As Integer, r As Range
    Dim wshRes As Worksheet
    Worksheets("Data").Select
    kRfin = Cells(Rows.Count, 3).End(xlUp).Row  '--- n° dernière ligne en colonne 3 (T°)
    Set wshRes = Worksheets("Résultat")
    wshRes.Cells.ClearContents
    For kr1 = 5 To kRfin - 1                    '--- de éch.1 à l'avant-dernier éch.
        wshRes.Cells(kr1, 1) = Cells(kr1, 1)
        wshRes.Cells(4, kr1 - 3) = Cells(kr1, 1)
        wshRes.Cells(kr1, kr1 - 3) = "#"
        For kr2 = kr1 + 1 To kRfin              '--- de éch. suivant au dernier éch.
            nIdem = 0
            For kC1 = 4 To 33                   '--- de test 1 (colonne 4) à test 20 (colonne 33)
                v = Cells(kr1, kC1)
                If v <> "" Then
                    kC2 = Int((kC1 - 4) / 5) * 5 + 4
                    nIdem = nIdem + WorksheetFunction.CountIf(Range(Cells(kr2, kC2), Cells(kr2, kC2 + 4)), v)
                    'Debug.Print kR1, kC1, v, kR2, kC2, nIdem, Range(Cells(kR2, kC2), Cells(kR2, kC2 + 4)).Address
                End If
            Next kC1
            'Debug.Print "---"
            DoEvents
            wshRes.Cells(kr1, kr2 - 3) = nIdem
        Next kr2
    Next kr1
    wshRes.Cells(kr1, 1) = Cells(kr1, 1)
    wshRes.Cells(4, kr1 - 3) = Cells(kr1, 1)
    wshRes.Cells(kr1, kr1 - 3) = "#"
    Worksheets("Résultat").Select
    Range("C5").Select
End Sub

Cas très particulier mal géré: celui où il y a 2 fois la même valeur dans un même groupe de test. Dans ce cas c'est compté 1 ou 2 fois selon comment cela tombe.
Aucune idée du temps que le calcul va prendre pour 500 échantillons.
Bonne continuation.