VBA, Traitement de donnees avec 2 variable

klin89 à dit:

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

VB:

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

Cliquez pour agrandir...