[ RESOLU par laurent950 ]Faire ressortir les doublons ...et

Guido

XLDnaute Accro
Bonjour le Forum

J'ai deux lignes avec des chiffres , une ligne avec 6 chiffres et une autre en dessous avec max 4 chiffres.

et j'aimerais faire afficher les chiffres cités 2 fois dans la page 2., Les formules matricielles

je ne maitrise pas..???

Mais avec les macros la je suis adepte, Donc je préfère le transfert des doublons en VBA

dans les 9 plages de la feuille 2.

Merci d'avance

Guido
 

Pièces jointes

  • Classeur1.xls
    61 KB · Affichages: 76

laurent950

XLDnaute Barbatruc
Bonsoir

VB:
Sub test()

Dim TabD() As Integer
Dim pos As Variant
pos = Array(3, 3)
Dim pos2 As Variant
pos2 = Array(3, 14)

For i = 1 To 9
ReDim TabD(1 To 10, 1 To 2)
doublon TabD, pos, pos2
' Position revu
pos(0) = pos(0) + 4
pos2(0) = pos2(0) + 4
pos2(1) = 14
Erase TabD
Next i

End Sub

VB:
Function doublon(TabD() As Integer, pos As Variant, pos2 As Variant)

    For i = LBound(TabD, 1) To UBound(TabD, 1)
        If i <= 6 Then
            TabD(i, 1) = Cells(pos(0), pos(1) + i)
        Else
            TabD(i, 1) = Cells(pos(0) + 2, i - pos(1))
        End If
    Next i
    i = Empty
  
    ' suppression des doubon
    For i = LBound(TabD, 1) To UBound(TabD, 1)
        For j = i + 1 To UBound(TabD, 1)
            If TabD(i, 1) = TabD(j, 1) Then
                TabD(i, 2) = "1"
            End If
        Next j
    Next i
    i = Empty
    j = Empty
  
    ' restitution
    For i = LBound(TabD, 1) To UBound(TabD, 1)
        If TabD(i, 2) = 1 Then
            If pos2(0) = 3 Then
                Cells(pos2(0), pos2(1)) = TabD(i, 1)
                pos2(1) = pos2(1) + 1
            Else
                Cells(pos2(0), pos2(1)) = TabD(i, 1)
                pos2(1) = pos2(1) + 1
            End If
        End If
    Next i
End Function
 

laurent950

XLDnaute Barbatruc
Avec la fonction tri incorporé

VB:
Sub test()

Dim TabD() As Integer
Dim pos As Variant
pos = Array(3, 3)
Dim pos2 As Variant
pos2 = Array(3, 14)

For i = 1 To 9
ReDim TabD(1 To 10, 1 To 2)
doublon TabD, pos, pos2
' Position revu
pos(0) = pos(0) + 4
pos2(0) = pos2(0) + 4
pos2(1) = 14
Erase TabD
Next i

End Sub

VB:
Function doublon(TabD() As Integer, pos As Variant, pos2 As Variant)

    For i = LBound(TabD, 1) To UBound(TabD, 1)
        If i <= 6 Then
            TabD(i, 1) = Cells(pos(0), pos(1) + i)
        Else
            TabD(i, 1) = Cells(pos(0) + 2, i - pos(1))
        End If
    Next i
    i = Empty
   
    ' suppression des doubon
    For i = LBound(TabD, 1) To UBound(TabD, 1)
        For j = i + 1 To UBound(TabD, 1)
            If TabD(i, 1) = TabD(j, 1) Then
                TabD(i, 2) = "1"
            End If
        Next j
    Next i
    i = Empty
    j = Empty
   
    ' restitution
    Dim n As Integer
    n = 1
    Dim temp() As Integer
    ReDim temp(1 To n)
    For i = LBound(TabD, 1) To UBound(TabD, 1)
        If TabD(i, 2) = 1 Then
            If pos2(0) = 3 Then
                Cells(pos2(0), pos2(1)) = TabD(i, 1)
                pos2(1) = pos2(1) + 1
                temp(n) = TabD(i, 1)
                n = n + 1
                ReDim Preserve temp(1 To n)
            Else
                Cells(pos2(0), pos2(1)) = TabD(i, 1)
                pos2(1) = pos2(1) + 1
                temp(n) = TabD(i, 1)
                n = n + 1
                ReDim Preserve temp(1 To n)
            End If
        End If
    Next i
    i = Empty
   
    n = n - 1
    ReDim Preserve temp(1 To n)
    ' fonction
    ' Tri
    Call tri(temp, 1, n)
        pos2(1) = 13
        For i = LBound(temp, 1) To UBound(temp, 1)
            Cells(pos2(0), pos2(1) + i) = temp(i)
        Next i
   
End Function


VB:
Sub tri(a() As Integer, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub
 
Dernière édition:

Guido

XLDnaute Accro
Bonsoir laurent950

Merci pour toutes ses propositions,

J'ai l'embarras du choix ,mais la je suis perdu, j'ai essayés mais je n'ai pas réussi a faire fonctionné

le fichier.

Puis te demander de me poster le fichier ,avec la solution le mieux adapter a ma demande..

Merci d'avance.

Guido
 

Discussions similaires

Statistiques des forums

Discussions
312 913
Messages
2 093 534
Membres
105 752
dernier inscrit
fred13340