Copier / coller Offset et addition

**Kitkas22** · 27/01/2025, 16h52

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 :

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
 
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 :

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
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 :

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

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) Nom : LOAD1.PNG
Affichages : 92
Taille : 1,37 Mo

Nom : LOAD1.PNG
Affichages : 92
Taille : 1,37 Mo

Nom : onsite.PNG
Affichages : 96
Taille : 127,8 Ko

**EricDgn** · 28/01/2025, 17h15

Eventuellement ceci:

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
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.

**Kitkas22** · 28/01/2025, 19h20

Envoyé par EricDgn

Eventuellement ceci:

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
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

**EricDgn** · 28/01/2025, 19h36

Sur quelle ligne ?

Si vous ajoutez ces instructions au niveau de la ligne 29

Code :

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

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?

**Kitkas22** · 28/01/2025, 19h53

Envoyé par EricDgn

Sur quelle ligne ?

Si vous ajoutez ces instructions au niveau de la ligne 29

Code :

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

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

Nom : Capture.PNG
Affichages : 55
Taille : 80,2 Ko

**EricDgn** · 28/01/2025, 21h46

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

**Kitkas22** · 28/01/2025, 22h26

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

Costing.xlsm

**EricDgn** · 28/01/2025, 23h55

Quelque chose comme ceci devrait faire l'affaire:

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
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.

**Kitkas22** · 03/02/2025, 22h58

Envoyé par EricDgn

Quelque chose comme ceci devrait faire l'affaire:

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
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,

Copier / coller Offset et addition

Macros et VBA Excel

Discussions similaires

Partager

Partager