VBA, Modification d'une macro, Trier des donnees par statut ou ordre de grandeur

[Johanes]

Bonjour,
Tout d abord merci de venir donner votre aide.

J ai modifie une macro qui maintenant fonctionne tres bien. sauf que je voudrais apporter 2 modifications que je n arrive pas a faire.

pour recapituler :

Toutes les semaines je recois une liste de client.
J'ai mis un petit exemple ci joint le fichier s'appelle Download.
Quand je recois le download j'utilise ma Macro 1.
J'ouvre les 2 fichiers je me met sur Download et je fait ALT + F8.
Ce qui me donne le fichier ci-joint "Download après Macro".

**** Maintenant le resultat fini je Copie coller les feuilles de Champagne et Water dans le document HK Spreadsheet, et je fais tourner HK la macro de HK spreadsheet ****

Je voudrais modifier ma "Macro1".
2 grosses modifications sont :

1) Uniquement pour les Feuilles "Bronze", "Silver", "Gold", "Platinum", "PlatPlus", "Ambassador". Faire en sorte que les numeros de chambre ne revienne pas 2 fois dans les differentes feuilles. et je voudrais garder le numero de chambre dans la feuille du plus grand statut en suivant cette ordre du plus petit au plus grand :
BRONZE < SILVER < GOLD < PLATIN < PLPLUS < AMBASS
Exemple : si j'ai 2 clients dans la meme chambre, 1 silver et 1 gold. Je veux que le numero de chambre avec le nom du client soit placer que dans la feuille Gold.

2) J'ai mis des conditions dans les feuilles Water et Chocostrawb.
a) Pour Water: Uniquement pour les status Gold, Platin, PlPlus, Ambass
b) pour Chocostrawb: uniquement pour Platin, Plplus, Ambass.

Si les clients ont 2 differents statut mais tout deux eligible sont dans la meme chambre je voudrais les mettre sur la meme ligne.
Exemple: pour water : Si un Gold et un Ambass sont dans la meme chambre la Macro les met sur une ligne differente.

Doit - on recommencer une toute nouvelle macro plus simple ou on peut juste modifier celle la ?

Merci de votre soutien.

 

[Johanes]

SVP j'ai besoin d'aide

 

[vgendron]

Meme réponse qu'ici
Lien supprimé

 

[Johanes]

Meme réponse qu'ici
Lien supprimé

Je vous ai mis la reponse ici : https://www.excel-downloads.com/thr...-feuilles-differentes.20016330/#post-20119146

 

[Johanes]

Meme réponse qu'ici
Lien supprimé

Avez vous jeter un coup d oeil a mon probleme ....

 

[klin89]

Bonsoir johanes

pour répondre au point 1 :

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, e, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 4)) Then
                ReDim w(1 To 4)
                ReDim b(1 To UBound(a, 1), 1 To 4)
                Set w(1) = CreateObject("Scripting.Dictionary")
                w(1).CompareMode = 1
                w(2) = 1
                w(3) = Array(4, 4)
                b(w(2), w(3)(0) - 3) = "Nbre": b(w(2), w(3)(0) - 2) = "Cabin"
                b(w(2), w(3)(0) - 1) = "Guest 1": b(w(2), w(3)(0)) = "Latitude 1"
                w(4) = b
                dico.Item(a(i, 4)) = w
            End If
            w = dico.Item(a(i, 4))
            b = w(4)
            If Not w(1).exists(a(i, 1)) Then
                w(2) = w(2) + 1
                b(w(2), w(3)(0) - 2) = a(i, 1)
                b(w(2), w(3)(0) - 1) = a(i, 3)
                b(w(2), w(3)(0)) = a(i, 5)
                w(1)(a(i, 1)) = w(2)
            Else
                w(3)(1) = w(3)(1) + 2
                If UBound(b, 2) < w(3)(1) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To w(3)(1))
                End If
                b(w(1)(a(i, 1)), w(3)(1) - 1) = a(i, 3)
                b(w(1)(a(i, 1)), w(3)(1)) = a(i, 5)
            End If
            w(4) = b
            dico.Item(a(i, 4)) = w
        Next
    End With
    For Each e In dico.keys
        w = dico.Item(e): b = w(4)
        b(2, 1) = dico.Item(e)(1).Count
        w(4) = b: dico.Item(e) = w
    Next
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    For Each e In dico.keys
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(e).Delete
        Sheets.Add().Name = e
        On Error GoTo 0
        With Sheets(e).Cells(1)
            With .Resize(dico.Item(e)(2), UBound(dico.Item(e)(4), 2))
                .Columns(2).NumberFormat = "@"
                .Value = dico.Item(e)(4)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .Font.Name = "calibri"
                .Font.Size = 9
                With .Cells(1, 3).Resize(, 2)
                    If UBound(dico.Item(e)(4), 2) > 4 Then
                        .AutoFill .Resize(, UBound(dico.Item(e)(4), 2) - 2)
                    End If
                End With
                With .Cells(2, 1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 15
                End With
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 6
                    .RowHeight = 16
                    .Font.Size = 10
                End With
                .Columns.AutoFit
            End With
        End With
    Next
    Set dico = Nothing
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

klin89