========DOUBLONS MACROS =========

[LE SERVICE PROMOTIONNEL DE XLD]

Bonjour,


Un cadeau exclusif réservé aux passionnés(e) d'Excel, offert à XLD,


Une envie de découvrir plus de doublons ?
avec DOUBLONS MACROS, en un click vous trouverez votre solution!!!

Larguez les amarres pour une des plus belles escales de XLD :
Destination cette fois-ci dans 2 fichiers démos sur les traces des Macros de Michel !!!

Si vous suivez le parcours fléché vous accéderez à des créations
événementielles et/ou très colorées.

Préparez-vous à sauter d'une feuille à l'autre,avec le click droit ou préférez afficher les onglets grâce à la barre de menu prévue à cet effet.
Allez, laissez vous tenter par Doublons Macros, la démo des deux compil' !!!

Avec les compliments des deux complices Michel et Celeda, ………..!!
et la participation des macros de
@+Thierry-Frederic Sigonneau-Jacques-Vincent-Ti-Zon


À télécharger en page d'accueil ou dans la centrale de XLD
SP XLD

 

[Dan]

Bonjour,

Eh bien voilà un fichier bien intéressant qui complète bien celui fait par Celeda et Monique.

Problèmes de doublons c'est pas ici !

Bonne journée

Dan

 

[Michel_M]

Bonsoir à tous

Super coucouné ce soir, le Père Michel_M...2 réalisations super: le grenier, tour à l'heure pour l'apéro, et pour la verveine du soir des macros à étudier, souvent "hachement "astucieuses avec une présentation très agréable.

Mon répertoire XLD downloads, qui stocke toutes les démos de formules et macros, astuces fourgonnés sur le forum, devient Hénorme et de temps en temps je fais le tour pour essayer de mémoriser: de + en + dur la mémo.


Donc, Bravo et Merci à vous 2, Michel le lapin sympa et Celeda du Kebek


Michel

 

[Zon]

Salut à tous,

Petite modif dans le code joint par Michel et Celeda dans le fichier pour la numérotation des doublons. Car application.transpose a une limite à 5000 et quelques lignes. Voici le code à mettre derrière l'userform:

Option Explicit
'adapté pour XL97, V2 application.transopose remplacé
Option Base 1
Const Titre = "Faites votre choix"
Const Lab = "Cliquez sur la colonne où se situent les noms des équipements"
Dim Tablo, Tablo2(), Tablo3()

Private Sub CommandButton1_Click()
With ListBox1
Select Case .ListIndex
Case -1: Exit Sub
Case 0: Insertion (2): Princ "C", 3
Case 1: Insertion (1): Princ "C", 3
Case Else: Princ Right(.List(.ListIndex), 1), .ListIndex + 1
End Select
Unload Me
End With
End Sub

Private Sub UserForm_Initialize()
Me.Caption = Titre
With Label1
.Caption = Lab
.AutoSize = True
End With
With ListBox1
.List = Array("Colonne A", "Colonne B", "Colonne C", _
"Colonne D", "Colonne E", "Colonne F")
End With
End Sub
Sub Princ(K As String, T As Byte)
Dim L1&, L2&, C&, Plage As Range
On Error Resume Next
Application.ScreenUpdating = False
L1 = Range(K & "1").End(xlDown).Row + 1
L2 = Range(K & 65536).End(xlUp).Row
C = Range("IV" & L1).End(xlToLeft).Column
Set Plage = Range(Range("A" & L1), Cells(L2, C))
Plage.Columns("A:B").ClearContents
Tri Plage, T
Tablo = TransposeGrandTab(Plage.Columns(T).Value)
Doublons
Plage.Columns(1) = TransposeGrandTab(Tablo2)
Plage.Columns(2) = TransposeGrandTab(Tablo3)
On Error GoTo 0
End Sub

Private Function Tri(Plage As Range, C As Byte)
With Plage
.Sort .Cells(C), xlAscending, , , , , , xlNo
End With
End Function

Private Sub Doublons()
Dim I&, J&, K&, L&, Item
ReDim Tablo2(UBound(Tablo, 2)): ReDim Tablo3(UBound(Tablo, 2))
J = 1: L = 1: K = 1
For I = LBound(Tablo, 2) To UBound(Tablo, 2)
If Item = Tablo(1, I) Then
J = J + 1: Tablo3(K) = J: K = K + 1
Else
Item = Tablo(1, I): J = 1
Tablo2(K) = L: Tablo3(K) = J
L = L + 1: K = K + 1
End If
Next I
End Sub
Private Function Insertion(Nb As Byte)
Dim I As Byte
For I = 1 To Nb
Columns(1).Insert
Next I
End Function
Function TransposeGrandTab(T) 'Zon
'Application.transpose est limité à 5000 et qques jusqu'à XL2002
Dim Temp, I&, J&, Z As Byte, Nb As Byte
On Error Resume Next
Do
Nb = Nb + 1
Z = UBound(T, Nb + 1)
Loop Until Err
If Nb = 1 Then
ReDim Temp(UBound(T), 1 To 1)
For I = LBound(T) To UBound(T)
Temp(I, 1) = T(I)
Next I
Else
ReDim Temp(UBound(T, 2), UBound(T, 1))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T, 1) To UBound(T, 1)
Temp(I, J) = T(J, I)
Next J
Next I
End If
TransposeGrandTab = Temp
End Function

A+++

 

[Celeda]

Bonjour,

Je n'ai pas Hassez de mots pour t'exprimer ma reconnaissance alors tout simplement Merci.

J'ai demandé à Michel de placer le nouveau code dans son wiki. Ainsi cela va nous éviter de faire une version 2 de suite. Ouf!!!!!!!

Si tu nous améliores les macros comme luky luke, nous on suivra plus.

Celeda

 

[Celeda et Michel]

Bonjour,

Dan, Michel_M : Hachement Merci à vous deux.

Michel & Celeda