Microsoft 365 Macro pour substituer une cellule par plusieurs cellules

bertchristophe · 14 Octobre 2023

bonjour, je cherche à faire un macro simple qui permette de remplacer une cellule par plusieurs autres cellules.
Contexte : je vends des produits au détail, et ces mêmes articles peuvent vendus en kit. Ma gestion commerciale me donne le nombre d'articles vendus au détail et le nombre de kits. j'aimerais savoir combien j'ai vendu de produits au total (vente au détail + vente dans des kits). j'ai donc d'un côté les ventes d'articles au détail, de l'autre les ventes de kit. j'ai un onglet avec le détail des kits. j'aimerais remplacer chaque ligne de kit dans mes ventes par toutes les lignes qui composent ce kit, ceci afin d'avoir un total des ventes via un TCD. Je pense qu'il faut passer par une macro, mais je ne maitrise pas la macro de "substitue". d'avance merci pour votre aide. PS : voir fichier joint.

job75 · 15 Octobre 2023

Bonjour,

Comme il y a kit et kit 2 il faut tester kit avec Like et le caractère générique *.

Et ajouter un test sur le code du kit pour traiter le kit adéquat.

Aussi modifier les colonnes des fonctions RECHERCHEV :

VB:

Sub Total_ventes()
Dim ventes, kit, d As Object, i&, code, q&, j&, n&
ventes = [H1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
kit = [A1].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ventes)
    If LCase(ventes(i, 2)) Like "kit*" Then
        code = ventes(i, 1)
        q = ventes(i, 3)
        For j = 2 To UBound(kit)
            If kit(j, 1) = code Then d(kit(j, 2)) = d(kit(j, 2)) + q * kit(j, 5)
        Next j
    Else
        d(ventes(i, 1)) = d(ventes(i, 1)) +...

chris · 14 Octobre 2023

Bonjour

Je ne sais d'où viennent tes données mais il semble y avoir un problème d'importation avec des caractères non reconnus

Il y a par ailleurs un problème de logique : tu as un unique code kit mais tes ventes supposées contentir des kits et des produits vendus seuls ont le même code produit qui est celui du kit...

Tout cela est faisable aisément via des requête PowerQuery si la logique est bonne... Pas besoin de VBA

job75 · 14 Octobre 2023

Bonsoir bertchristophe, chris,

Voici la macro affectée au bouton :

VB:

Sub Total_ventes()
Dim ventes, kit, d As Object, i&, q&, j&, n&
ventes = [A4].CurrentRegion.Resize(, 3) 'matrice, plus rapide
kit = [A18].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ventes)
    If LCase(ventes(i, 2)) = "kit" Then
        q = ventes(i, 3)
        For j = 2 To UBound(kit)
            d(kit(j, 2)) = d(kit(j, 2)) + q * kit(j, 5)
        Next j
    Else
        d(ventes(i, 1)) = d(ventes(i, 1)) + ventes(i, 3)
    End If
Next i
'---restitution---
n = d.Count
With [F4] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n) = Application.Transpose(d.keys)
        .Offset(, 1).Resize(n) = "=IFERROR(VLOOKUP(RC[-1],C1:C2,2,0),VLOOKUP(RC[-1],C2:C3,2,0))"
        .Offset(, 2).Resize(n) = Application.Transpose(d.items)
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub

A+

bertchristophe · 15 Octobre 2023

chris à dit:
Bonjour

Je ne sais d'où viennent tes données mais il semble y avoir un problème d'importation avec des caractères non reconnus

Il y a par ailleurs un problème de logique : tu as un unique code kit mais tes ventes supposées contentir des kits et des produits vendus seuls ont le même code produit qui est celui du kit...

Tout cela est faisable aisément via des requête PowerQuery si la logique est bonne... Pas besoin de VBA

bonjour
merci pour ces éléments de réponse. je vais creuser la piste suggérée. bon dimanche

bertchristophe · 15 Octobre 2023

job75 à dit:

Bonsoir bertchristophe, chris,

Voici la macro affectée au bouton :

VB:

Sub Total_ventes()
Dim ventes, kit, d As Object, i&, q&, j&, n&
ventes = [A4].CurrentRegion.Resize(, 3) 'matrice, plus rapide
kit = [A18].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ventes)
    If LCase(ventes(i, 2)) = "kit" Then
        q = ventes(i, 3)
        For j = 2 To UBound(kit)
            d(kit(j, 2)) = d(kit(j, 2)) + q * kit(j, 5)
        Next j
    Else
        d(ventes(i, 1)) = d(ventes(i, 1)) + ventes(i, 3)
    End If
Next i
'---restitution---
n = d.Count
With [F4] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n) = Application.Transpose(d.keys)
        .Offset(, 1).Resize(n) = "=IFERROR(VLOOKUP(RC[-1],C1:C2,2,0),VLOOKUP(RC[-1],C2:C3,2,0))"
        .Offset(, 2).Resize(n) = Application.Transpose(d.items)
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub

A+

bonjour
merci pour les informations. je jetterai un oeil à votre solution en fin d'après-midi. encore merci et bon dimanche

bertchristophe · 15 Octobre 2023

job75 à dit:

Bonsoir bertchristophe, chris,

Voici la macro affectée au bouton :

VB:

Sub Total_ventes()
Dim ventes, kit, d As Object, i&, q&, j&, n&
ventes = [A4].CurrentRegion.Resize(, 3) 'matrice, plus rapide
kit = [A18].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ventes)
    If LCase(ventes(i, 2)) = "kit" Then
        q = ventes(i, 3)
        For j = 2 To UBound(kit)
            d(kit(j, 2)) = d(kit(j, 2)) + q * kit(j, 5)
        Next j
    Else
        d(ventes(i, 1)) = d(ventes(i, 1)) + ventes(i, 3)
    End If
Next i
'---restitution---
n = d.Count
With [F4] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n) = Application.Transpose(d.keys)
        .Offset(, 1).Resize(n) = "=IFERROR(VLOOKUP(RC[-1],C1:C2,2,0),VLOOKUP(RC[-1],C2:C3,2,0))"
        .Offset(, 2).Resize(n) = Application.Transpose(d.items)
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub

A+

rebonjour
j'essaie de faire des choses simples via le VBA, et d'adapter le fichier que tu m'as gentiment transmis mais j'avoue rencontrer encore un problème. en fait j'essaie d'adapter à plus de kits, mais j'ai du mal à adapter la logique "resize". j'ai intégré un deuxième kit en colonne A (mais en fait je pourrais en avoir plusieurs dizaines si j'extrais tout de ma base de données). j'ai rajouté une vente (H95). mais la zone de calcule automatique ne va pas me chercher le détail du kit 2 dans le renvoi des ventes. sans vouloir abuser, si tu as une explication, ce serait cool. j'ai essayé de chercher sur le web, mais je sèche.

job75 · 15 Octobre 2023

Bonjour,

Comme il y a kit et kit 2 il faut tester kit avec Like et le caractère générique *.

Et ajouter un test sur le code du kit pour traiter le kit adéquat.

Aussi modifier les colonnes des fonctions RECHERCHEV :

VB:

Sub Total_ventes()
Dim ventes, kit, d As Object, i&, code, q&, j&, n&
ventes = [H1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
kit = [A1].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ventes)
    If LCase(ventes(i, 2)) Like "kit*" Then
        code = ventes(i, 1)
        q = ventes(i, 3)
        For j = 2 To UBound(kit)
            If kit(j, 1) = code Then d(kit(j, 2)) = d(kit(j, 2)) + q * kit(j, 5)
        Next j
    Else
        d(ventes(i, 1)) = d(ventes(i, 1)) + ventes(i, 3)
    End If
Next i
'---restitution---
n = d.Count
With [L4] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n) = Application.Transpose(d.keys)
        .Offset(, 1).Resize(n) = "=IFERROR(VLOOKUP(RC[-1],C2:C3,2,0),VLOOKUP(RC[-1],C8:C9,2,0))"
        .Offset(, 2).Resize(n) = Application.Transpose(d.items)
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub

A+

bertchristophe · 15 Octobre 2023

un grand merci, il me manquait effectivement cette étape du "*".
bonne fin de week end

Microsoft 365 Macro pour substituer une cellule par plusieurs cellules

bertchristophe

XLDnaute Nouveau

Pièces jointes

job75

chris

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

bertchristophe

XLDnaute Nouveau

bertchristophe

XLDnaute Nouveau

bertchristophe

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

bertchristophe

XLDnaute Nouveau

Discussions similaires