VBA Copie données relative au sous.totaux

[demahom08]

bonjour a tous

j'ai besoin d'aide pour copier des données relatives a leur sous totaux

mon fichier comporte des Types ,des noms , des montants et leur références.

conditions:

* trié par type
* pour chaque changement de nom je veux avoir un solde
* nommé le client de chaque solde
* pour chaque solde supérieur a 500 le copier sur une autre feuille mais j'ai besoin des détail de chaque solde (copier avec les lignes qui concerne le solde critère )
* pour tout type différent du 5I a supprimé les données de la colonne affectation
* avoir les huit caractères de droite de la colonne affectation pour le type 5I et remplacer avec les données qui reste sur la colonne affectation

 

[job75]

Re : VBA Copie données relative au sous.totaux

Bonsoir demahom08,

Ce n'est pas simple mais en utilisant le filtre automatique c'est très faisable.

Je vous ferai cela demain.

Bonne nuit.

 

[job75]

Re : VBA Copie données relative au sous.totaux

Bonjour demahom08, le forum,

Voyez cette macro dans le fichier joint (Alt+F11) :

Sub SousTotaux()
Dim P As Range, dest As Range, col%, lig&, d As Object
Dim i&, filtre As Range, h&, c As Range, adr$, j&
Set P = Sheets("BDD").[B1].CurrentRegion 'à adapter
Set dest = Sheets("Sous-totaux").[B2] 'à adapter
Application.ScreenUpdating = False
dest(2).Resize(Rows.Count - dest.Row).EntireRow.Delete 'RAZ
col = P.Columns.Count
lig = 2
Set d = CreateObject("Scripting.Dictionary")
P.AutoFilter 'met en place ou retire le filtre automatique
For i = 2 To P.Rows.Count
  If Not d.Exists(P(i, 1).Value) Then 'élimine les doublons
    d(P(i, 1).Value) = ""
    P.AutoFilter 1, P(i, 1) 'filtrage 1ère colonne
    Set filtre = P.Offset(1).SpecialCells(xlCellTypeVisible)
    h = filtre.Count / col
    Set c = dest(lig)
    filtre.Copy c 'copie la plage filtrée
    adr = c(1, col - 1).Resize(h - 1).Address(0, 0)
    c(h, col - 1) = "=SUBTOTAL(9," & adr & ")"
    If c(h, col - 1) > 500 Then 'critère adaptable
      c(h) = c
      c(h, 2) = c(h - 1, 2) 'le dernier nom
      For j = 1 To h - 1
        c(j, col) = IIf(c(j, 4) = "5I", Right(c(j, col), 8), "")
      Next
      c(h, 2).Font.Bold = True 'gras
      c(h, col - 1).Interior.ColorIndex = 6 'jaune
      lig = lig + h
    Else
      c.Resize(h).EntireRow.Delete 'plage supprimée
    End If
  End If
Next
P.AutoFilter 'retire le filtre
dest(lig, 2) = "général"
dest(lig, 2).Font.Bold = True 'gras
adr = dest(1, col - 1).Resize(lig - 1).Address(0, 0)
dest(lig, col - 1) = "=SUBTOTAL(9," & adr & ")"
dest(lig, col - 1).NumberFormat = dest(lig - 1, col - 1).NumberFormat
dest.Resize(, col).EntireColumn.AutoFit 'ajustement largeur
dest.Resize(lig - 1, col).Sort dest, Header:=xlYes 'tri 1ère colonne
dest.Parent.Activate
End Sub

Elle se lance quand on active la feuille Sous-totaux, mais cela pourrait se faire par un bouton.

Nota 1 : pour le code client CPD 37 il y a 2 noms différents, est-ce normal ?

Nota 2 : il y a un sous-total par code client, cela semble logique.

Nota 3 : si les nombres obtenus en colonne I "Affectation" commencent par un zéro, il faut mettre cette colonne au format Texte.

Nota 4 : le tri final se fait sur la colonne des codes clients.

On pourrait aussi le faire sur le montant des sous-totaux. Il faudrait alors utiliser une colonne auxiliaire.

A+

 

[job75]

Re : VBA Copie données relative au sous.totaux

Re,

Cette version (2) donne le choix de trier par sous-total (tri décroissant) :

Sub SousTotaux()
Dim choix As Boolean, P As Range, dest As Range, col%, lig&
Dim d As Object, i&, filtre As Range, h&, c As Range, adr$, j&
Set P = Sheets("BDD").[B1].CurrentRegion 'à adapter
Set dest = Sheets("Sous-totaux").[B2] 'à adapter
choix = MsgBox("Voulez-vous trier par sous-total ?", 36, "Tri") = 6
Application.ScreenUpdating = False
dest(2).Resize(Rows.Count - dest.Row).EntireRow.Delete 'RAZ
col = P.Columns.Count
lig = 2
Set d = CreateObject("Scripting.Dictionary")
P.AutoFilter 'met en place ou retire le filtre automatique
For i = 2 To P.Rows.Count
  If Not d.Exists(P(i, 1).Value) Then 'élimine les doublons
    d(P(i, 1).Value) = ""
    P.AutoFilter 1, P(i, 1) 'filtrage 1ère colonne
    Set filtre = P.Offset(1).SpecialCells(xlCellTypeVisible)
    h = filtre.Count / col
    Set c = dest(lig)
    filtre.Copy c 'copie la plage filtrée
    adr = c(1, col - 1).Resize(h - 1).Address(0, 0)
    c(h, col - 1) = "=SUBTOTAL(9," & adr & ")"
    If c(h, col - 1) > 500 Then 'critère adaptable
      c(h) = c
      c(h, 2) = c(h - 1, 2) 'le dernier nom
      For j = 1 To h - 1
        c(j, col) = IIf(c(j, 4) = "5I", Right(c(j, col), 8), "")
      Next
      If choix Then c(1, col + 1).Resize(h) = c(h, col - 1)
      c(h, 2).Font.Bold = True 'gras
      c(h, col - 1).Interior.ColorIndex = 6 'jaune
      lig = lig + h
    Else
      c.Resize(h).EntireRow.Delete 'plage supprimée
    End If
  End If
Next
P.AutoFilter 'retire le filtre
dest(lig, 2) = "général"
dest(lig, 2).Font.Bold = True 'gras
adr = dest(1, col - 1).Resize(lig - 1).Address(0, 0)
dest(lig, col - 1) = "=SUBTOTAL(9," & adr & ")"
dest(lig, col - 1).NumberFormat = dest(lig - 1, col - 1).NumberFormat
dest.Resize(, col).EntireColumn.AutoFit 'ajustement largeur
dest.Resize(lig - 1, col + 1) _
  .Sort dest(1, 1 - col * choix), 1 - choix, Header:=xlYes 'tri selon choix
If choix Then dest(1, col + 1).EntireColumn.Delete
dest.Parent.Activate
End Sub

A+