VBA, Traitement de donnees avec 2 variable

[Johanes]

Bonjour,

J'ai un fichier de Base appele download Ci dessous :

J'ai une Macro pour trier les donnees:
Il y a 2 variables:
1) La premiere c'est la colonne D: Differents Statuts.
2) la deuxieme c'est la colonne A : Numero de chambre


une fois que je fais tourner ma Macro J'ai feuille qui s'appelle "Water".
Dans cette feuille Seul les clients qui ont dans la colonne D : "GOLD", "PLATIN", "PLPLUS", "AMBASS".

Jusque la je n'ai pas de probleme.

Mais dans ma feuille water si j'ai 2 client dans la meme chambre qui sont 1 GOLD et 1 PLATIN : La macro les met sur une ligne differente =>Voir ci dessous :

Ce que je voudrais c'est si dans la colonne B ce sont les memes numeros de chambre je voudrais les mettre sur la meme ligne comme sur les lignes 2,3,4,et 5.

Je vous met ci-joint mon document de base "Download" et ma "Macro2"

 

[klin89]

Bonjour johanes,

Peux-tu arrêter de nous envoyer tes fichiers à la pelle et notamment tes fichiers vides
on ne comprend plus rien à tes demandes

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, w(), dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    With Sheets("Sheet1").Cells(1).CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 1 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1: dico.Item(a(i, 1)) = VBA.Array(n, 3)
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 3)
                b(n, 3) = a(i, 4)
            Else
                w = dico.Item(a(i, 1))
                w(1) = w(1) + 2
                If UBound(b, 2) < w(1) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 2)
                End If
                b(w(0), w(1) - 1) = a(i, 3)
                b(w(0), w(1)) = a(i, 4)
                dico.Item(a(i, 1)) = w
            End If
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Restitution").Delete
    Sheets.Add().Name = "Restitution"
    On Error GoTo 0
    With Sheets("Restitution").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Columns(1).NumberFormat = "@"
        .Value = b
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .VerticalAlignment = xlCenter
        .Font.Name = "calibri"
        .Font.Size = 9
        With .Cells(1, 2).Resize(, 2)
            .Cells(1, 1).Value = .Cells(1, 1).Value & " 1"
            .Cells(1, 2).Value = .Cells(1, 2).Value & " 1"
            If UBound(b, 2) > 3 Then
                .AutoFill .Resize(, UBound(b, 2) - 1)
            End If
        End With
        With .Rows(1)
            .BorderAround Weight:=xlThin
            .HorizontalAlignment = xlCenter
            .Interior.ColorIndex = 37
            .RowHeight = 18
            .Font.Size = 10
        End With
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[Johanes]

Bonjour johanes,

Peux-tu arrêter de nous envoyer tes fichiers à la pelle et notamment tes fichiers vides
on ne comprend plus rien à tes demandes

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, w(), dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    With Sheets("Sheet1").Cells(1).CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 1 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1: dico.Item(a(i, 1)) = VBA.Array(n, 3)
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 3)
                b(n, 3) = a(i, 4)
            Else
                w = dico.Item(a(i, 1))
                w(1) = w(1) + 2
                If UBound(b, 2) < w(1) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 2)
                End If
                b(w(0), w(1) - 1) = a(i, 3)
                b(w(0), w(1)) = a(i, 4)
                dico.Item(a(i, 1)) = w
            End If
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Restitution").Delete
    Sheets.Add().Name = "Restitution"
    On Error GoTo 0
    With Sheets("Restitution").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Columns(1).NumberFormat = "@"
        .Value = b
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .VerticalAlignment = xlCenter
        .Font.Name = "calibri"
        .Font.Size = 9
        With .Cells(1, 2).Resize(, 2)
            .Cells(1, 1).Value = .Cells(1, 1).Value & " 1"
            .Cells(1, 2).Value = .Cells(1, 2).Value & " 1"
            If UBound(b, 2) > 3 Then
                .AutoFill .Resize(, UBound(b, 2) - 1)
            End If
        End With
        With .Rows(1)
            .BorderAround Weight:=xlThin
            .HorizontalAlignment = xlCenter
            .Interior.ColorIndex = 37
            .RowHeight = 18
            .Font.Size = 10
        End With
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour,

Je n'envoie pas de fichier vide... le fichier macro tu dois faire ALT + F11 et ça t'ouvre la macro...

 

[Johanes]

Ton code marche si je le met tout seul hors j'ai deja un code mais je n'arrive pas a regler le probleme si je met une condition il ne prend plus en compte le numero de chambre.... peux tu m'aider stp

 

[ChTi160]

Bonjour johanes
Bonjour le fil "Klin89" ,Le Forum
Klin89 très beau travail !
Johanes , je ne comprends pas tout lol
Ca y est , j ai compris ! lol
Amicalement
Jean marie

 

[ChTi160]

Bonsoir johanes
Bonsoir le fil,Le Forum
je ne sais pas si le sujet est clos ! Lol
Mias , je joins mon fichier !
Bonne fin de Soirée
Amicalement
Jean marie