Ajouter resize

Bonjour à tous

je voudrais ajouter l'instruction resize dans mon code VBA pour redimensionne mon tableau et éviter les doublant.

Voici mon code :

Sub Image4_Cliquer()

Dim i As Integer, j As Integer, Rng, Alt()

Application.ScreenUpdating = False

Range("B26:G100").ClearContents
Rows("2:1000").RowHeight = 15
j = 25

With Sheets("BD")

    For i = 3 To .Range("C" & Rows.Count).End(xlUp).Row
        If .Range("I" & i) = Date Then
            j = j + 1

           Range("B" & j) = .Range("C" & i)
           Range("C" & j) = .Range("H" & i)
           Range("D" & j) = .Range("G" & i)
           Range("E" & j) = .Range("I" & i)
           Range("F" & j) = .Range("J" & i)
        End If
    Next i

  End With

End Sub

Merci d'avance pour votre aide.

Cordialement .

Bonjour,

Que veux-tu donc redimensionner ?

Bonjour,

Voici la pièce jointe, ça sera plus clair.

Merci de votre attention.

Cordialement,

Bonjour,

à mon avis le resize n'a rien à voir...

tu veux un total du client 2 avec le délai 31 et client 6 délai 19 si date identique ..

Un TCD ou un code VBA avec dictionnaire peut le faire

P.

Bonjour,

Je ne sais pas si j'ai bien compris le problème...

En tout cas, j'ai fait quelques aménagements :

• coloration des lignes alternée de ton tableau d'échéance mise en MFC
• la macro prendra en compte la date figurant en I24 pour extraire l'échéance (si I24 est vide elle prend la date du jour), cela permet de diversifier l'extraction à la demande (et diversifier les tests sans rien modifier !)

La proc. rattachée à ton image (loupe) :

Sub Echéance()
    Dim Alt(), d As Object, k, col, mt, de, Rng As Range, i%, j%
    With Worksheets("BD")
        Set Rng = .Range("C6:J" & .Range("C" & .Rows.Count).End(xlUp).Row)
    End With
    col = Array(1, 6, 8)
    de = IIf(ActiveSheet.Range("I24") <> "", ActiveSheet.Range("I24").Value2, Date)
    Set d = CreateObject("Scripting.Dictionary")
    With Rng
        For i = 1 To .Rows.Count
            If .Cells(i, 7) = de Then
                For j = 0 To UBound(col)
                    k = k & "|" & .Cells(i, col(j)).Value2
                Next j
                If d.exists(k) Then
                    mt = Val(Replace(d(k), ",", "."))
                    d(k) = mt + .Cells(i, 5)
                Else
                    d(k) = .Cells(i, 5)
                End If
                k = ""
            End If
        Next i
    End With
    If d.Count > 0 Then
        ReDim Alt(d.Count - 1, 4): j = 0
        For Each k In d.keys
            Alt(j, 2) = Val(Replace(d(k), ",", ".")): Alt(j, 3) = de
            k = Split(k, "|")
            Alt(j, 0) = k(1): Alt(j, 1) = k(2): Alt(j, 4) = k(3)
            j = j + 1
        Next k
    End If
    Application.ScreenUpdating = False
    With ActiveSheet.Range("B26")
        .CurrentRegion.Offset(1).ClearContents
        If d.Count > 0 Then .Resize(j, 5).Value = Alt
    End With
End Sub

A toi de tester.

Cordialement.

edit : Salut Patrick !

Bonjour,

Génial ....

Merci à tous pour vos réponses!

le code fourni par MFerrand a parfaitement fonctionné.

je tiens à vous remercier pour votre aide et votre soutien.

Excellente journée à tous.

Cordialement,