Macro avec Boucle repeter jusqu'a

Bonjour à tous et bonnes fêtes de fin d'année ,

Je m'excuse par avance si mon sujet est déjà traité, je ne l'ai pas trouvé dans ces 800 et quelque pages de question.

Je tiens à préciser que je ne m'y connais pas du tout en VBA ou en code de manière général mais j'ai des notions basique d'algo.

Je vous explique mon problème :

Je souhaite faire une macro Excel qui affiche tous les serveurs sur lesquels est une application A, puis tous les serveurs sur lesquels est une application B et ainsi de suite (résultat final : liste des serveurs application par application). La base de donnée peut être mise à jour régulièrement (création/suppression d'une application) et la liste des applications sur un serveur peut être édité.

Pour le moment j'ai fait ça mais ce n'est pas opérationnel puisque si les informations sont éditées le résultat final est faux (décalage des cellules), de plus, si une nouvelle application est créée il faut éditer la macro : (fait avec l'enregistreur de macro)

      ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "=*A*", Operator:=xlAnd
    Range("Tableau1").Select
    Selection.Copy
    Sheets("RésultatApresMacro").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "A"
    Selection.AutoFill Destination:=Range("C1:C5"), Type:=xlFillDefault
    Range("C1:C5").Select
    Sheets("Data").Select
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "=*B*", Operator:=xlAnd
    Selection.Copy
    Sheets("RésultatApresMacro").Select
    Range("A6").Select
    ActiveSheet.Paste
    Range("C6").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "B"
    Selection.AutoFill Destination:=Range("C6:C8"), Type:=xlFillDefault
    Range("C6:C8").Select
    Sheets("Data").Select
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "=*C*", Operator:=xlAnd
    Selection.Copy
    Sheets("RésultatApresMacro").Select
    Range("A9").Select
    ActiveSheet.Paste
    Range("C9").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "C"
    Selection.AutoFill Destination:=Range("C9:C12"), Type:=xlFillDefault
    Range("C9:C12").Select
    Sheets("Data").Select
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "=*D*", Operator:=xlAnd
    Selection.Copy
    Sheets("RésultatApresMacro").Select
    Range("A13").Select
    ActiveSheet.Paste
    Range("C13").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "D"
    Selection.AutoFill Destination:=Range("C13:C17"), Type:=xlFillDefault
    Range("C13:C17").Select
    Sheets("Data").Select
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "=*E*", Operator:=xlAnd
    Selection.Copy
    Sheets("RésultatApresMacro").Select
    Range("A18").Select
    ActiveSheet.Paste
    Range("C18").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "E"
    Selection.AutoFill Destination:=Range("C18:C21"), Type:=xlFillDefault
    Range("C18:C21").Select
    Range("A1").Select
    Sheets("Data").Select
    Range("C4").Select
End Sub

Pourriez-vous m’éclairer sur la façon de procéder s'il vous plait.

Le fichier est joint ci cela peut vous aider à mieux comprendre ma requête.

Je vous remercie de l'attention que vous porterez à mon post

Bonjour

En pièce jointe une proposition.

Voici les étapes:

On prend toutes les applis dans bases de données et on les dispatche dans le tableau résultat

on tri par ordre alphabétique

Ensuite on parcourt la deuxième feuille. Si l'application de la ligne ( ex: A) est dans la colonne de droite des serveurs en utilisant un comparatif majuscule et minuscule ( ex : on chercche l appli A et dans les listes de serveur on a B,a,D ca matche quand même )

cdt,

Bonjour,

D'après tes explications, j'aurais vu plutôt le pendant de ton premier tableau...

Ainsi :

Sub ListerServeurs()
    Dim d As Object, T, k, i%, j%
    Set d = CreateObject("Scripting.Dictionary")
    With [Tableau1]
        For i = 1 To .Rows.Count
            T = Split(.Cells(i, 2), ",")
            For j = 0 To UBound(T)
                If d.exists(T(j)) Then
                    d(T(j)) = d(T(j)) & "," & .Cells(i, 1)
                Else
                    d(T(j)) = .Cells(i, 1)
                End If
            Next j
        Next i
    End With
    T = d.keys
    For i = 0 To UBound(T) - 1
        For j = i + 1 To UBound(T)
            If T(j) < T(i) Then
                k = T(j): T(j) = T(i): T(i) = k
            End If
        Next j
    Next i
    With [Tableau3]
        .ClearContents
        .Cells(1, 1).Resize(UBound(T) + 1) = WorksheetFunction.Transpose(T)
        For i = 1 To UBound(T) + 1
            .Cells(i, 2) = d(.Cells(i, 1).Value)
        Next i
        .Worksheet.Activate
    End With
End Sub

(Ça peut être amélioré, je n'ai pas trop fignolé la chose...)

Cordialement.

Bonjour,

Merci beaucoup MFerrand et ti_chou_3

Cela fonctionne niquel c'est super ,

J'aurais juste pensé une autre mise en forme et vos macros sont trop compliquées pour moi, je n'ose pas y toucher et tout casser.

Savez-vous s'il est possible d'afficher la liste des serveurs appli par appli dans des cellules séparées ?

Vous trouverez dans la feuille "RésultatApresMacro" la mise en forme que j'avais en tête.

Encore une fois je vous remercie pour ce que vous m'avez proposé qui est génial

Cordialement

Eldewen

Bonjour,

Sub ListerServeurs2()
    Dim d As Object, T(), k, i%, j%
    Set d = CreateObject("Scripting.Dictionary")
    With [Tableau1]
        For i = 1 To .Rows.Count
            k = Split(.Cells(i, 2), ",")
            For j = 0 To UBound(k)
                d(k(j) & " " & .Cells(i, 1).Value) = ""
            Next j
        Next i
    End With
    ReDim T(d.Count, 1): k = d.keys
    For i = 0 To UBound(k)
        T(i + 1, 0) = k(i)
    Next i
    For i = 1 To UBound(T, 1) - 1
        For j = i + 1 To UBound(T, 1)
            If T(j, 0) < T(i, 0) Then
                T(0, 0) = T(j, 0): T(j, 0) = T(i, 0): T(i, 0) = T(0, 0)
            End If
        Next j
    Next i
    For i = 1 To UBound(T, 1)
        k = Split(T(i, 0)): T(i, 0) = k(0): T(i, 1) = k(1)
    Next i
    T(0, 0) = "Serveur": T(0, 1) = "Application"
    With Worksheets("RésultatApresMacro")
        .Range("F3").CurrentRegion.ClearContents
        .Range("F1").Resize(UBound(T, 1) + 1, 2).Value = T
        .Activate
    End With
End Sub

NB- J'ai considéré jusqu'à présent que les appellations des applications et serveurs pouvaient avoir n'importe quel libellé, ce pourquoi les numéros de serveurs n'ont pas été traités en tant que nombres pour le tri, et 10 apparaît donc logiquement après 1...

Cordialement.

Merci beaucoup MFerrand, t'es un vrai pro d'Excel

C'est exactement ce dont j'avais besoin !

Étant donné que le sujet est résolu, et que je me rends désormais compte que mon titre n'est pas tout à fait en rapport, comment dois-je le renommer ?

Cordialement

Eldewen