Discussion :

[Freudsw]

Bonjour à tous,

j'ai créé un tableau croisé dynamique à partir d'une base de données, mon tableau contient toujours 6 colonnes et pluieurs lignes (ça change à chaque fois que ma base de données change).
Mon but est de créer une macro VBA qui me permettrait de copier ce tableau et le coller dans une feuille appelée (échantillon) qui se trouve dans le même classeur dans un premier temps.

Par la suite je voudrais opérer quelques traitements sur ce tableau :
1. La derniere colonne contient des chiffre (négatif et positif), j'aimerais créer une autre colonne ou je prendras la valeur absolu de chaque ligne.
2. Ensuite, de supprmier toutes les lignes dont le chiffre de la derniere colonne dépasserait 150K.
3. En dernier lieu, j'aimerais selectionner aléatoirement 6 lignes de cette échantion, les copier et les coller dans une autre feuille apellée (CPN).

un début de code serait le bienvenue.

Merci par avance.

Cordialement,
Freudsw

[Kimy_Ire]

Bonjour Freudsw,

Je crois n'être pas très loin de ce que tu recherches avec ça :

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
Option Explicit
 
Sub Freudsw()
Dim oRng As Range
Dim i As Integer
Dim oTable() As Double, x As Integer
Dim oRnd As Integer, oTrouve As Integer
 
Set oRng = Worksheets("Feuil4").UsedRange
With Worksheets("échantillon")
    .Range("A1").Resize(oRng.Rows.Count, oRng.Columns.Count).Value = oRng.Value
    Set oRng = .Range("F1")
    For i = .Cells(.Cells.Rows.Count, 6).End(xlUp).Row - 1 To 1 Step -1
        If IsNumeric(oRng.Offset(i, 0)) Then
            oRng.Offset(i, 1) = Abs(oRng.Offset(i, 0))
            If oRng.Offset(i, 1) >= 150000 Then
                oRng.Offset(i, 1).EntireRow.Delete
            End If
        End If
    Next i
 
    Set oRng = .Range("G1")
    x = 1
    For i = 1 To .Cells(.Cells.Rows.Count, 7).End(xlUp).Row - 1
        If oRng.Offset(i, 0) <> "" Then
            ReDim Preserve oTable(1 To 2, 1 To x)
            oTable(1, x) = oRng.Offset(i, 0)
            oTable(2, x) = oRng.Offset(i, 0).Row
            x = x + 1
        End If
    Next i
 
    If UBound(oTable, 2) >= 6 Then
        Worksheets("CPN").Cells.ClearContents
        oTrouve = 0
        Do While oTrouve < 6
            Randomize
            oRnd = Int((UBound(oTable, 2) - LBound(oTable, 2) + 1) * Rnd + LBound(oTable, 2))
            If oTable(1, oRnd) >= 0 Then
                Worksheets("CPN").Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = .Cells(oTable(2, oRnd), 1).EntireRow.Value
                oTable(1, oRnd) = -1
                oTrouve = oTrouve + 1
            End If
        Loop
    Else
        MsgBox "Pas 6 lignes différentes dans le tableau."
    End If
End With
 
End Sub

Je pense qu'il y a plus simple mais c'est fonctionnel, il me semble. ^^
N'hésite pas à revenir vers moi !

Cordialement,
Kimy

[Freudsw]

Bonjour Kimy,

Le code fonctionne parfaitement, mais il y a un petit soucis ; lors de la selection aléatoire des 6 lignes, j'ai l'impression que le code prends en considération même les lignes vides.
il y a moyen de régler ce problème ?

Et aussi, quand je copie le tableau source, il y a moyen de commencer par la deuxieme ligne ?

Merci encore.

Cordialement,
Freudsw

[Kimy_Ire]

Bonjour Freudsw,

Voici avec les commentaires :

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
Option Explicit
 
Sub Freudsw()
'Déclaration des variables
Dim oRng As Range
Dim i As Integer
Dim oTable() As Double, x As Integer
Dim oRnd As Integer, oTrouve As Integer
 
'On définie oRng comme l'ensemble des cellules utilisées de Feuil4
Set oRng = Worksheets("Feuil4").UsedRange
'Avec "échantillon"
With Worksheets("échantillon")
    'On recopie les valeurs de oRng en A1
    .Range("A1").Resize(oRng.Rows.Count, oRng.Columns.Count).Value = oRng.Value
    'On redéfinie oRng sur F1 de "échantillon"
    Set oRng = .Range("F1")
 
    'On boucle de i = dernière ligne non vide de la colonne 7 à 1 (décroissant)
    For i = .Cells(.Cells.Rows.Count, 6).End(xlUp).Row - 1 To 1 Step -1
        'Si on a une valeur numérique en oRng avec un décalage de i lignes...
        If IsNumeric(oRng.Offset(i, 0)) Then
            '... alors sur la colonne à droite on place sa valeur absolue
            oRng.Offset(i, 1) = Abs(oRng.Offset(i, 0))
            'Si cette valeur absolue est >= à 150000
            If oRng.Offset(i, 1) >= 150000 Then
                'On supprime la ligne
                oRng.Offset(i, 1).EntireRow.Delete
            End If
        End If
    Next i
 
    'On redéfinie oRng sur la cellule G1 (toujours de "échantillon")
    Set oRng = .Range("G1")
    'On définie x = 1
    x = 1
 
    'On boucle de i = 1 à la dernière ligne non vide de la colonne 7
    For i = 1 To .Cells(.Cells.Rows.Count, 7).End(xlUp).Row - 1
        'Si oRng avec un décalage de i ligne est différent de "rien"
        If oRng.Offset(i, 0) <> "" Then
            'Alors on refédinie le tableau oTable
            ReDim Preserve oTable(1 To 2, 1 To x)
            'On lui ajoute la valeur
            oTable(1, x) = oRng.Offset(i, 0)
            'Et la ligne
            oTable(2, x) = oRng.Offset(i, 0).Row
            'Et on agrandi x (ou agrandir la tableau, par la suite)
            x = x + 1
        End If
    Next i
 
    'Si le nombre de valeur de oTable est suppérieur à 6
    If UBound(oTable, 2) >= 6 Then
        'Avec la feuille "CPN" on supprime toutes les valeurs
        Worksheets("CPN").Cells.ClearContents
        'On définie oTrouve = 0
        oTrouve = 0
 
        'On boucle tant que oTrouve est inférieur à 6
        Do While oTrouve < 6
            'On Randomize
            Randomize
            'On set oRnd comme un nombre aléatoire compris entre la plus petite et la plus grande dimension du tableau oTable
            oRnd = Int((UBound(oTable, 2) - LBound(oTable, 2) + 1) * Rnd + LBound(oTable, 2))
            'Si oTable(1, Rnd) >= 0 (logiquement on a que des valeurs absolues)
            If oTable(1, oRnd) >= 0 Then
                'Alors on recopie la ligne entière
                Worksheets("CPN").Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = .Cells(oTable(2, oRnd), 1).EntireRow.Value
                'Et on redéfinie la valeur de oTable comme égale à -1 (comme ça on ne la resélectionnera pas)
                oTable(1, oRnd) = -1
                'Et on a trouvé une valeur donc on ajoute 1 à oTrouve
                oTrouve = oTrouve + 1
            End If
        Loop
    Else
        MsgBox "Pas 6 lignes différentes dans le tableau."
    End If
End With
 
End Sub

Je te laisse adapter !

Cordialement,
Kimy

[Freudsw]

re-bonjour Kimy

Merci encore une fois pour l'aide.
je n'ai pas pu adapter ton code à mon besoin (la partie ou il fallait selectionner 6 lignes aléatoires), du coup j'ai procédé d'une autre maniére et ça marche parfaitement.

Maintenant j'ai un autre souci; mon tableau croisé dynamique contient des cellules vides, ce que je voudrais faire dans le traitement (feuille échatillon), c'est de remplir ces cellules avec la valeurs qui se trouve dans la ligne au dessus.
comment je pourrais integrer ceci dans mon code ?

je te remercie encore une fois pour ta disponibilité.

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
Option Explicit
 
Sub traitement()
'Déclaration des variables
Dim oRng As Range
Dim t As Integer
Dim ListeLig As String
Dim LigChoisie As String
Dim i As Integer
Dim oTable() As Double, x As Integer
Dim oRnd As Integer, oTrouve As Integer
 
'On définie oRng comme l'ensemble des cellules utilisées de la feuille TCD
Set oRng = Worksheets("TCD").UsedRange
'Avec "échantillon"
With Worksheets("Échantillon")
    'On recopie les valeurs de oRng en A1
    .Range("A1").Resize(oRng.Rows.Count, oRng.Columns.Count).Value = oRng.Value
    'On redéfinie oRng sur F1 de "échantillon"
    Set oRng = .Range("F1")
 
    'On boucle de i = dernière ligne non vide de la colonne 7 à 1 (décroissant)
    For i = .Cells(.Cells.Rows.Count, 6).End(xlUp).Row - 1 To 1 Step -1
        'Si on a une valeur numérique en oRng avec un décalage de i lignes...
        If IsNumeric(oRng.Offset(i, 0)) Then
            '... alors sur la colonne à droite on place sa valeur absolue
            oRng.Offset(i, 1) = Abs(oRng.Offset(i, 0))
            'Si cette valeur absolue est < à 150000
            If oRng.Offset(i, 1) < 150000 Then
                'On supprime la ligne
                oRng.Offset(i, 1).EntireRow.Delete
            End If
        End If
    Next i
 
    'On redéfinie oRng sur la cellule G1 (toujours de "Échantillon")
    Set oRng = .Range("G3")
    'On définie x = 1
    x = 1
 
    'On boucle de i = 1 à la dernière ligne non vide de la colonne 7
    For i = 1 To .Cells(.Cells.Rows.Count, 7).End(xlUp).Row - 1
        'Si oRng avec un décalage de i ligne est différent de "rien"
        If oRng.Offset(i, 0) <> "" Then
            'Alors on refédinie le tableau oTable
            ReDim Preserve oTable(1 To 2, 1 To x)
            'On lui ajoute la valeur
            oTable(1, x) = oRng.Offset(i, 0)
            'Et la ligne
            oTable(2, x) = oRng.Offset(i, 0).Row
            'Et on agrandi x (ou agrandir la tableau, par la suite)
            x = x + 1
        End If
    Next i
 
    'Si le nombre de valeur de oTable est suppérieur à 6
    If UBound(oTable, 2) >= 6 Then
       With ThisWorkbook.Worksheets("Échantillon")
        ListeLig = ""  ' initialisation de la liste des lignes choisies pour cette feuille
        For i = 1 To 6  ' on va piocher trois lignes
 
            ' définition de la ligne piochées
            LigChoisie = Int((.Cells(.Rows.Count, 1).End(xlUp).Row - 3) * Rnd + 3)
 
            ' tant que la ligne piochée a déjà été utilisée
            While ListeLig Like "*$" & LigChoisie & "$*"
                ' on en pioche une autre
                LigChoisie = Int((.Cells(.Rows.Count, 1).End(xlUp).Row - 3) * Rnd + 3)
            Wend
 
            ' on ajoute la ligne piochée à la liste des lignes utilisées
            ListeLig = ListeLig & "$" & LigChoisie & "$"
            ' on écrit la ligne
           .Cells(LigChoisie, 1).Resize(1, .UsedRange.Columns.Count).Copy ThisWorkbook.Worksheets("CPN1").Cells(2, 1).Offset(t, 0)
            t = t + 1
        Next i
    End With
    Else
        MsgBox "Pas 6 lignes différentes dans le tableau."
    End If
End With
 
End Sub

Cordialement,
Freudsw

[Freudsw]

R-bonjour,

Le code fonctionne parfaitement.
j'ai reussi à ajouter le bout de code qui me permetrrait de remplir les cellules vides avec le contenu de la cellule qui se trouve juste au dessus.

Merci encore Kimy.

Cordialement,
Freudsw

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
Option Explicit
 
Sub traitement()
'Déclaration des variables
Dim oRng As Range
Dim t As Integer
Dim ListeLig As String
Dim LigChoisie As String
Dim i, j As Integer
Dim oTable() As Double, x As Integer
Dim oRnd As Integer, oTrouve As Integer
 
'On définie oRng comme l'ensemble des cellules utilisées de la feuille TCD
Set oRng = Worksheets("TCD").UsedRange
'Avec "échantillon"
With Worksheets("Échantillon")
    'On recopie les valeurs de oRng en A1
    .Range("A1").Resize(oRng.Rows.Count, oRng.Columns.Count).Value = oRng.Value
    'On redéfinie oRng sur F1 de "échantillon"
    Set oRng = .Range("F1")
 
    'On boucle de i = dernière ligne non vide de la colonne 7 à 1 (décroissant)
    For i = .Cells(.Cells.Rows.Count, 6).End(xlUp).Row - 1 To 1 Step -1
        'Si on a une valeur numérique en oRng avec un décalage de i lignes...
        If IsNumeric(oRng.Offset(i, 0)) Then
            '... alors sur la colonne à droite on place sa valeur absolue
            oRng.Offset(i, 1) = Abs(oRng.Offset(i, 0))
            'Si cette valeur absolue est < à 150000
            If oRng.Offset(i, 1) < 150000 Then
                'On supprime la ligne
                oRng.Offset(i, 1).EntireRow.Delete
            End If
        End If
    Next i
 
    'le code qui permet de remplir les cellules vides
    Set oRng = .Range("A3")
    For i = 0 To .Cells(.Cells.Rows.Count, 1).End(xlUp).Row - 1
    For j = 0 To 4
    If oRng.Offset(i, j) = "" Then
    oRng.Offset(i, j).Value = oRng.Offset(i - 1, j)
    End If
    Next j
    Next i
 
 
 
    'On redéfinie oRng sur la cellule G1 (toujours de "Échantillon")
    Set oRng = .Range("G3")
    'On définie x = 1
    x = 1
 
    'On boucle de i = 1 à la dernière ligne non vide de la colonne 7
    For i = 1 To .Cells(.Cells.Rows.Count, 7).End(xlUp).Row - 1
        'Si oRng avec un décalage de i ligne est différent de "rien"
        If oRng.Offset(i, 0) <> "" Then
            'Alors on refédinie le tableau oTable
            ReDim Preserve oTable(1 To 2, 1 To x)
            'On lui ajoute la valeur
            oTable(1, x) = oRng.Offset(i, 0)
            'Et la ligne
            oTable(2, x) = oRng.Offset(i, 0).Row
            'Et on agrandi x (ou agrandir la tableau, par la suite)
            x = x + 1
        End If
    Next i
 
    'Si le nombre de valeur de oTable est suppérieur à 6
    If UBound(oTable, 2) >= 6 Then
       With ThisWorkbook.Worksheets("Échantillon")
        ListeLig = ""  ' initialisation de la liste des lignes choisies pour cette feuille
        For i = 1 To 6  ' on va piocher trois lignes
 
            ' définition de la ligne piochées
            LigChoisie = Int((.Cells(.Rows.Count, 1).End(xlUp).Row - 3) * Rnd + 3)
 
            ' tant que la ligne piochée a déjà été utilisée
            While ListeLig Like "*$" & LigChoisie & "$*"
                ' on en pioche une autre
                LigChoisie = Int((.Cells(.Rows.Count, 1).End(xlUp).Row - 3) * Rnd + 3)
            Wend
 
            ' on ajoute la ligne piochée à la liste des lignes utilisées
            ListeLig = ListeLig & "$" & LigChoisie & "$"
            ' on écrit la ligne
           .Cells(LigChoisie, 1).Resize(1, .UsedRange.Columns.Count).Copy ThisWorkbook.Worksheets("CPN1").Cells(2, 1).Offset(t, 0)
            t = t + 1
        Next i
    End With
    Else
        MsgBox "Pas 6 lignes différentes dans le tableau."
    End If
End With
 
End Sub