Copier / coller Offset et addition

Version imprimable

2 pièce(s) jointe(s)

Je tente de copier des données d'un tableau vers un nouveau.

Par contre, je dois additionné les valeurs positive dans toutes les colonnes par multiple de 5.
Mon index de colonne est J. Donc, je dois relever les valeurs dans (J,10), (J,15), (J,20), (J,25) etc.... (encadré en rouge dans le tableau)

Je n'arrive pas à formuler mon vba correctement
Mais de base ce code fonctionne pour copier qu'une seule colonne (sans addition).

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
 
Sub OnSite()
 
 
     Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, RgCible As Range
     Dim Données(), Résultats(), NewRés()
     Dim i As Long, j As Long, NbL As Long, NbC As Long
     Const NbColRés = 10
 
     Set Source = ActiveWorkbook.Worksheets("CHARGEMENT")
     Set Cible = ActiveWorkbook.Worksheets("ON SITE")
 
     Set RgSource = Source.Range("D12:BB1519") 'Plage contenant toutes les données
     Set RgCible = Cible.Range("A6")         '1ère cellule de la plage cible
 
     Application.ScreenUpdating = False
 
     'On nettoie la cible (valeurs et formats)
     RgCible.Resize(Cible.Rows.Count - RgCible.Row + 1, NbColRés).Clear
 
     'on stocke dans un tableau de variables toutes les valeurs de la plage de données
     Données = RgSource.Value2
 
     'i : Index pour de décalage en ligne de la plage cible
     i = 0
 
     For j = 1 To UBound(Données, 1)  'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
          If IsNumeric(Données(j, 10)) And Not IsEmpty(Données(j, 10)) Then
               If Données(j, 10) > 0 Then
                    'Ici Données(j, 10) est une valeur numérique supérieure à 0
 
                              'On incrémente i pour le prochain résultat
                              i = i + 1
                              'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
                              '————————————————————————————————————————————————————————————————————————————
                              'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
                              '————————————————————————————————————————————————————————————————————————————
                              ReDim Preserve Résultats(1 To NbColRés, 1 To i)
                              Résultats(1, i) = Données(j, 1)
                              Résultats(2, i) = Données(j, 2)
                              Résultats(3, i) = Données(j, 5)
                              Résultats(4, i) = Données(j, 4)
                              Résultats(5, i) = Données(j, 10)
 
               End If
          End If
     Next
 
     If i = 0 Then
    MsgBox "Aucune ligne ne correspond aux critères"
    Exit Sub
 
End If
 
     'On transpose les résultats pour passer dans un tableau en lignes, colonnes
     NbL = UBound(Résultats, 2) 'Nbre de lignes = dimension 2 du tableau Résultats
     NbC = UBound(Résultats, 1) 'Nbre de colonnes = dimension 1 du tableau Résultats
     'Nouveau tableau de Résultats
     ReDim NewRés(1 To NbL, 1 To NbC)
     'Transposition
     For i = 1 To NbL
          For j = 1 To NbC
               NewRés(i, j) = Résultats(j, i)
          Next j
     Next i
 
     'On attribue à la plage cible redimensionnée les résultats
     RgCible.Resize(NbL, NbC).Value2 = NewRés
 
     'On se positionne juste au dessus de la cellule cible (True : avec défilement d'écran)
     Application.Goto RgCible.Offset(-1, 0), True
 
     Application.ScreenUpdating = True
 
 
End Sub

Il me permets de transcrire les données de cette façon dans une nouvelle page "on site" comme ci-dessous.
Pièce jointe 663851

Ce que j'aimerais c'est modifier cette section du code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
For j = 1 To UBound(Données, 1)  'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
          If IsNumeric(Données(j, 10)) And Not IsEmpty(Données(j, 10)) Then
               If Données(j, 10) > 0 Then
                    'Ici Données(j, 10) est une valeur numérique supérieure à 0
 
                              'On incrémente i pour le prochain résultat
                              i = i + 1
                              'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
                              '————————————————————————————————————————————————————————————————————————————
                              'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
                              '————————————————————————————————————————————————————————————————————————————
                              ReDim Preserve Résultats(1 To NbColRés, 1 To i)
                              Résultats(1, i) = Données(j, 1)
                              Résultats(2, i) = Données(j, 2)
                              Résultats(3, i) = Données(j, 5)
                              Résultats(4, i) = Données(j, 4)
                              Résultats(5, i) = Données(j, 10)

Pour me permettre d'additionnée des données à la colonne " Résultats(5, i) = Données(j, 10)" J'aimerais avoir une somme de toutes les colonnes " load" (en rouge dans l'image)" soit une formule qui me permets d'avoir " Résultats(5, i) = somme des Données(j, 10)+ offset 5....."

Je sais que pour ça je dois ajouter un case ou une incrémentation avant d'arriver au résultat mais je ne sais pas comment l'insérer dans cette section du code.

Code:

1
2
3
4
 
          If IsNumeric(Données(j, 10)) And Not IsEmpty(Données(j, 10)) Then
               If Données(j, 10) > 0 Then  
                    'Ici Données(j, 10) est une valeur numérique supérieure à 0

En rouge, les colonnes que je veut additionné, si les cellules contiennent quelque chose
En bleu, ce sont les autres informations qui doivent apparaître dans mon tableau lorsqu'il y a quelque chose dans la colonne load.

Pièce jointe 663853

Finalement, dans mon tableau de résultats "on site". J'aimerais que la colonne quantity contiennent la somme de mes colonnes " loads" (en rouge)Pièce jointe 663900 Pièce jointe 663901

Eventuellement ceci:

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
Option Explicit
 
 
Sub OnSite()
     Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, RgCible As Range
     Dim Données(), Résultats(), NewRés()
     Dim i As Long, j As Long, NbL As Long, NbC As Long
     Dim Total As Long
     Const NbColRés = 10
 
     Set Source = ActiveWorkbook.Worksheets("CHARGEMENT")
     Set Cible = ActiveWorkbook.Worksheets("ON SITE")
 
     Set RgSource = Source.Range("D12:BB1519") 'Plage contenant toutes les données
     Set RgCible = Cible.Range("A6")         '1ère cellule de la plage cible
 
     Application.ScreenUpdating = False
 
     'On nettoie la cible (valeurs et formats)
     RgCible.Resize(Cible.Rows.Count - RgCible.Row + 1, NbColRés).Clear
 
     'on stocke dans un tableau de variables toutes les valeurs de la plage de données
     Données = RgSource.Value2
 
     'i : Index pour de décalage en ligne de la plage cible
     i = 0
 
     For j = 1 To UBound(Données, 1)  'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
          Total = Données(j, 10) + Données(j, 15) + Données(j, 20) + Données(j, 25)
          If Total > 0 Then
                'On incrémente i pour le prochain résultat
                i = i + 1
                'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
                '————————————————————————————————————————————————————————————————————————————
                'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
                '————————————————————————————————————————————————————————————————————————————
                ReDim Preserve Résultats(1 To NbColRés, 1 To i)
                Résultats(1, i) = Données(j, 1)
                Résultats(2, i) = Données(j, 2)
                Résultats(3, i) = Données(j, 5)
                Résultats(4, i) = Données(j, 4)
                Résultats(5, i) = Total
          End If
     Next
 
     If i = 0 Then
        MsgBox "Aucune ligne ne correspond aux critères"
        Exit Sub
     End If
 
     'On transpose les résultats pour passer dans un tableau en lignes, colonnes
     NbL = UBound(Résultats, 2) 'Nbre de lignes = dimension 2 du tableau Résultats
     NbC = UBound(Résultats, 1) 'Nbre de colonnes = dimension 1 du tableau Résultats
     'Nouveau tableau de Résultats
     ReDim NewRés(1 To NbL, 1 To NbC)
     'Transposition
     For i = 1 To NbL
          For j = 1 To NbC
               NewRés(i, j) = Résultats(j, i)
          Next j
     Next i
 
     'On attribue à la plage cible redimensionnée les résultats
     RgCible.Resize(NbL, NbC).Value2 = NewRés
 
     'On se positionne juste au dessus de la cellule cible (True : avec défilement d'écran)
     Application.Goto RgCible.Offset(-1, 0), True
 
     Application.ScreenUpdating = True
 
End Sub

Cordialement.

Citation:

Envoyé par EricDgn

Eventuellement ceci:

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
Option Explicit
 
 
Sub OnSite()
     Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, RgCible As Range
     Dim Données(), Résultats(), NewRés()
     Dim i As Long, j As Long, NbL As Long, NbC As Long
     Dim Total As Long
     Const NbColRés = 10
 
     Set Source = ActiveWorkbook.Worksheets("CHARGEMENT")
     Set Cible = ActiveWorkbook.Worksheets("ON SITE")
 
     Set RgSource = Source.Range("D12:BB1519") 'Plage contenant toutes les données
     Set RgCible = Cible.Range("A6")         '1ère cellule de la plage cible
 
     Application.ScreenUpdating = False
 
     'On nettoie la cible (valeurs et formats)
     RgCible.Resize(Cible.Rows.Count - RgCible.Row + 1, NbColRés).Clear
 
     'on stocke dans un tableau de variables toutes les valeurs de la plage de données
     Données = RgSource.Value2
 
     'i : Index pour de décalage en ligne de la plage cible
     i = 0
 
     For j = 1 To UBound(Données, 1)  'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
          Total = Données(j, 10) + Données(j, 15) + Données(j, 20) + Données(j, 25)
          If Total > 0 Then
                'On incrémente i pour le prochain résultat
                i = i + 1
                'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
                '————————————————————————————————————————————————————————————————————————————
                'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
                '————————————————————————————————————————————————————————————————————————————
                ReDim Preserve Résultats(1 To NbColRés, 1 To i)
                Résultats(1, i) = Données(j, 1)
                Résultats(2, i) = Données(j, 2)
                Résultats(3, i) = Données(j, 5)
                Résultats(4, i) = Données(j, 4)
                Résultats(5, i) = Total
          End If
     Next
 
     If i = 0 Then
        MsgBox "Aucune ligne ne correspond aux critères"
        Exit Sub
     End If
 
     'On transpose les résultats pour passer dans un tableau en lignes, colonnes
     NbL = UBound(Résultats, 2) 'Nbre de lignes = dimension 2 du tableau Résultats
     NbC = UBound(Résultats, 1) 'Nbre de colonnes = dimension 1 du tableau Résultats
     'Nouveau tableau de Résultats
     ReDim NewRés(1 To NbL, 1 To NbC)
     'Transposition
     For i = 1 To NbL
          For j = 1 To NbC
               NewRés(i, j) = Résultats(j, i)
          Next j
     Next i
 
     'On attribue à la plage cible redimensionnée les résultats
     RgCible.Resize(NbL, NbC).Value2 = NewRés
 
     'On se positionne juste au dessus de la cellule cible (True : avec défilement d'écran)
     Application.Goto RgCible.Offset(-1, 0), True
 
     Application.ScreenUpdating = True
 
End Sub

Cordialement.

Malheureusement ça ne fonctionne pas
Il incique incompatibilité de type

28/01/2025, 18h36
EricDgn
Sur quelle ligne ?

Si vous ajoutez ces instructions au niveau de la ligne 29
Code:

1 2 3 4 Debug.Print Données(j, 10) Debug.Print Données(j, 15) Debug.Print Données(j, 20) Debug.Print Données(j, 25)
Sur quelle ligne cela bloque?
28/01/2025, 18h53
Kitkas22

1 pièce(s) jointe(s)
Citation:
Envoyé par EricDgn

Sur quelle ligne ?

Si vous ajoutez ces instructions au niveau de la ligne 29

Code:

1 2 3 4 Debug.Print Données(j, 10) Debug.Print Données(j, 15) Debug.Print Données(j, 20) Debug.Print Données(j, 25)

Sur quelle ligne cela bloque?
Voir ligne en jaune

Pièce jointe 663949
28/01/2025, 20h46
EricDgn

Pourriez-vous joindre une feuille Excel avec quelques lignes de données (fichier .xlsx sans macro)?
28/01/2025, 21h26
Kitkas22

1 pièce(s) jointe(s)

Citation:

Envoyé par EricDgn

Pourriez-vous joindre une feuille Excel avec quelques lignes de données (fichier .xlsx sans macro)?

Bien sur!
Voici une partie de mon document

Pièce jointe 663957

Quelque chose comme ceci devrait faire l'affaire:

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
Option Explicit
 
Sub OnSite()
    Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, RgCible As Range
    Dim Données(), Résultats(), NewRés()
    Dim i As Long, j As Long, NbL As Long, NbC As Long
    Dim k As Long, Total As Long
    Const NbColRés = 10
 
    'Set Source = ActiveWorkbook.Worksheets("CHARGEMENT")
    Set Source = ActiveWorkbook.Worksheets("Shipping List")
 
    Set Cible = ActiveWorkbook.Worksheets("ON SITE")
    Cible.Cells.Clear                                           '--- vider la feuille avant reprise calculs
 
    Set RgSource = Source.Range("D12:BB1519")  'Plage contenant toutes les données
    Set RgCible = Cible.Range("A6")            '1ère cellule de la plage cible
 
    Application.ScreenUpdating = False
 
    'On nettoie la cible (valeurs et formats)
    RgCible.Resize(Cible.Rows.Count - RgCible.Row + 1, NbColRés).Clear
 
    'on stocke dans un tableau de variables toutes les valeurs de la plage de données
    Données = RgSource.Value2
 
    'i : Index pour de décalage en ligne de la plage cible
    i = 0
 
    For j = 2 To UBound(Données, 1)        'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
        Total = 0
        For k = 11 To 26 Step 5                     '--- 11 to 26   ou   11 to 46  ?
            If IsNumeric(Données(j, k)) Then
                Total = Total + Données(j, k)
            End If
        Next k
 
        If Total > 0 Then
             'On incrémente i pour le prochain résultat
             i = i + 1
             'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
             '————————————————————————————————————————————————————————————————————————————
             'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
             '————————————————————————————————————————————————————————————————————————————
             ReDim Preserve Résultats(1 To NbColRés, 1 To i)
             Résultats(1, i) = Données(j, 1)
             Résultats(2, i) = Données(j, 2)
             Résultats(3, i) = Données(j, 5)
             Résultats(4, i) = Données(j, 4)
             Résultats(5, i) = Total
        End If
    Next
 
    If i = 0 Then
        MsgBox "Aucune ligne ne correspond aux critères"
        Exit Sub
    End If
 
    'On transpose les résultats pour passer dans un tableau en lignes, colonnes
    NbL = UBound(Résultats, 2) 'Nbre de lignes = dimension 2 du tableau Résultats
    NbC = UBound(Résultats, 1) 'Nbre de colonnes = dimension 1 du tableau Résultats
    'Nouveau tableau de Résultats
    ReDim NewRés(1 To NbL, 1 To NbC)
    'Transposition
    For i = 1 To NbL
        For j = 1 To NbC
             NewRés(i, j) = Résultats(j, i)
        Next j
    Next i
 
    'On attribue à la plage cible redimensionnée les résultats
    RgCible.Resize(NbL, NbC).Value2 = NewRés
 
    'On se positionne juste au dessus de la cellule cible (True : avec défilement d'écran)
    Application.Goto RgCible.Offset(-1, 0), True
 
    Application.ScreenUpdating = True
 
End Sub

A vérifier.
Cordialement.

Citation:

Envoyé par EricDgn

Quelque chose comme ceci devrait faire l'affaire:

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
Option Explicit
 
Sub OnSite()
    Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, RgCible As Range
    Dim Données(), Résultats(), NewRés()
    Dim i As Long, j As Long, NbL As Long, NbC As Long
    Dim k As Long, Total As Long
    Const NbColRés = 10
 
    'Set Source = ActiveWorkbook.Worksheets("CHARGEMENT")
    Set Source = ActiveWorkbook.Worksheets("Shipping List")
 
    Set Cible = ActiveWorkbook.Worksheets("ON SITE")
    Cible.Cells.Clear                                           '--- vider la feuille avant reprise calculs
 
    Set RgSource = Source.Range("D12:BB1519")  'Plage contenant toutes les données
    Set RgCible = Cible.Range("A6")            '1ère cellule de la plage cible
 
    Application.ScreenUpdating = False
 
    'On nettoie la cible (valeurs et formats)
    RgCible.Resize(Cible.Rows.Count - RgCible.Row + 1, NbColRés).Clear
 
    'on stocke dans un tableau de variables toutes les valeurs de la plage de données
    Données = RgSource.Value2
 
    'i : Index pour de décalage en ligne de la plage cible
    i = 0
 
    For j = 2 To UBound(Données, 1)        'J varie de 1 aux nombre de lignes de la plage des données (ici 1508 lignes)
 
        Total = 0
        For k = 11 To 26 Step 5                     '--- 11 to 26   ou   11 to 46  ?
            If IsNumeric(Données(j, k)) Then
                Total = Total + Données(j, k)
            End If
        Next k
 
        If Total > 0 Then
             'On incrémente i pour le prochain résultat
             i = i + 1
             'On redimensionne le tableau Résultats et on le remplit (au début i vaut 1)
             '————————————————————————————————————————————————————————————————————————————
             'Remarque : le tableau est en colonnes-lignes et non pas en lignes-colonnes
             '————————————————————————————————————————————————————————————————————————————
             ReDim Preserve Résultats(1 To NbColRés, 1 To i)
             Résultats(1, i) = Données(j, 1)
             Résultats(2, i) = Données(j, 2)
             Résultats(3, i) = Données(j, 5)
             Résultats(4, i) = Données(j, 4)
             Résultats(5, i) = Total
        End If
    Next
 
    If i = 0 Then
        MsgBox "Aucune ligne ne correspond aux critères"
        Exit Sub
    End If
 
    'On transpose les résultats pour passer dans un tableau en lignes, colonnes
    NbL = UBound(Résultats, 2) 'Nbre de lignes = dimension 2 du tableau Résultats
    NbC = UBound(Résultats, 1) 'Nbre de colonnes = dimension 1 du tableau Résultats
    'Nouveau tableau de Résultats
    ReDim NewRés(1 To NbL, 1 To NbC)
    'Transposition
    For i = 1 To NbL
        For j = 1 To NbC
             NewRés(i, j) = Résultats(j, i)
        Next j
    Next i
 
    'On attribue à la plage cible redimensionnée les résultats
    RgCible.Resize(NbL, NbC).Value2 = NewRés
 
    'On se positionne juste au dessus de la cellule cible (True : avec défilement d'écran)
    Application.Goto RgCible.Offset(-1, 0), True
 
    Application.ScreenUpdating = True
 
End Sub

A vérifier.
Cordialement.

Merci énormément
Je n'avais pas vu votre réponse avant car j'ai travaillé sur un autre projet mais celà fonctionne à merveille! C'est exactement ce qu'il me fallait
et Merci pour les explications du code je vais pouvoir l'étudier pour le comprendre pour une prochaine fois.

Bonne journée,