RechercheV Résolu

Question

Bonjour, 

J'ai trouvé cette macro sur ce site que j'aurais besoin d'utiliser mais elle marche mal
Ce que j'aimerai c'est :
j'ai un fichier excel dans lequel j'ai deux onglets Docteur1 et Docteur2 qui ont déja soigné les memes clients: chaque client est identifiable par un numéro client(qui se trouve en colonne1), j'aimerai créer à partir de ces deux onglets un autre onglet qui me donne tous les clients en commun dans ces deux onglets initiaux   ex:
onglet1:
NumClient(que j'ai en colonneA)
FR0125867
CC0354874
BO1578496
ST0045127
AT0584166
US0014872

onglet2:
NumClient(que j'ai en colonneA)
FR0125867
GH0154796
ST0045127
AE0145769
BU0147852

Dans  ces deux onglets je n'ai que les deux numéro client en commun donc j'aimerai avoir dans mon nouvel onglet que
FR0125867
ST0045127
bien sur j'ai beaucoup plus de clients que ca dans mes onglets(plusieurs milliers)
Merci J'ai trouvé cette macro sur ce site que j'aurais besoin d'utiliser mais elle marche mal
(si vous avez une idée avec une formule XL ca ira aussi très bien, j'ai essayé avec RECHERHCEV mais j'arrive pas)
    Merci             

Option Explicit
Option Base 1
Dim T_ens() As String, Col As Byte

Sub repertorier_cursus_entier()

Dim Lig As Integer, Cptr As Integer, Nbre As Integer
Dim Dico As Object
Dim Commun As Byte, ref As String, Nbre_cle As Integer
Dim Lig_fin As Integer, Indice As Integer, ISIN As String, Champ As Byte
Dim Staff, T_out

'répertorie les enseignements
Nbre = ThisWorkbook.Sheets.Count
 ReDim T_ens(Nbre)
 For Cptr = 1 To Nbre
     T_ens(Cptr) = Sheets(Cptr).Name
Next
'et le nombre de colonnes
Col = Sheets(T_ens(1)).Range("z1").End(xlToLeft).Column
Application.ScreenUpdating = False
preparer_classeur
'Nbre = 3 'essais
'------cree la liste des etudiants communs

Set Dico = CreateObject("scripting.dictionary")
     With Sheets(T_ens(1))
          Lig_fin = .Range("A1").End(xlDown).Row
        For Lig = 2 To Lig_fin
               ref = .Cells(Lig, 1)
               Commun = 1
               For Cptr = 2 To Nbre
                    If Application.CountIf(Sheets(T_ens(Cptr)).Columns(1), ref) = 1 Then Commun = Commun + 1
               Next Cptr
               If Commun = UBound(T_ens) Then Dico.Add ref, ref
         Next Lig
     End With
     Nbre_cle = Dico.Count
    Staff = Dico.items
     
     ReDim T_out(Dico.Count, Col)
     For Cptr = 1 To Nbre
          With Sheets(T_ens(Cptr))
               For Indice = 0 To UBound(Staff)
                    ISIN = Staff(Indice)
                    Lig = .Columns(1).Find(ISIN, .Range("A1")).Row
                    T_out(Indice + 1, 1) = ISIN
                    For Champ = 2 To Col
                         T_out(Indice + 1, Champ) = .Cells(Lig, Champ)
                    Next Champ
               Next Indice
               With Sheets(Cptr + Nbre)
                    .Activate
                    With .Range("A2").Resize(Nbre_cle, Col)
                         .Value = T_out
                         .Borders.Weight = xlThin
                    End With
               End With
          End With
     Next Cptr
End Sub
Sub preparer_classeur()
Dim Cptr As Byte, Num As Byte, Champs




'créé les fiches des "communs"
With Sheets(T_ens(1))
     'copie les ent^tes
     Champs = Application.Transpose(.Range(.Cells(1, 1), .Cells(1, Col)).Value)
End With
Num = UBound(T_ens)

For Cptr = 1 To Num
            Sheets.Add After:=Sheets(Num)
            
             Num = Num + 1
            Sheets(Num).Select
     
     Sheets(Num).Name = T_ens(Cptr) & "_ISIN_communs"
     
     'colle les entêtes
        With Range("A1").Resize(1, Col)
            .Value = Application.Transpose(Champs)
            .Borders.Weight = xlThin
     End With
Next

End Sub









Configuration: Windows XP / Internet Explorer 8.0

eriiic · Answer

Bonjour,

pour ceux qui répondront tu as oublié une précision :
1) est-ce que c'est à lancer à chaque fois sur une feuille vierge
ou 2) ou bien tu seras amenée à saisir d'autres colonnes à conserver et de temps en temps tu relanceras pour compléter les nouvelles entrées.

eric

Morgothal · Answer

Salut,
Elle m'a l'air bien compliquée cette macro ...

Chez moi celle-ci fonctionne; j'ai mis un peu de temps à bien trouver l'ordre des For...Next mais cette fois ça marche !

Sub recherchepatientsidentiques()
Dim ligneA, ligneB, ligneC As Integer
Dim compteurA, compteurB, compteurC As Integer
Dim patientA, patientB As String
Dim test As Integer

'recherche nombre lignes remplie dans la premiere feuille
Sheets("Docteur A").Select
compteurA = 1
While Cells(compteurA, 1) <> ""
    compteurA = compteurA + 1
Wend

'recherche nombre lignes remplie dans la seconde feuille
Sheets("Docteur B").Select
compteurB = 1
While Cells(compteurB, 1) <> ""
    compteurB = compteurB + 1
Wend

For ligneA = 1 To compteurA - 1
Sheets("Docteur A").Select
patientA = Cells(ligneA, 1)

    For ligneB = 1 To compteurB - 1
    Sheets("Docteur B").Select
    patientB = Cells(ligneB, 1)
    
        If patientA = patientB Then
            
            'recherche nombre lignes remplie dans la troisième feuille
            Sheets("Patients").Select
            compteurC = 1
            While Cells(compteurC, 1) <> ""
                compteurC = compteurC + 1
            Wend
            test = 0
            For ligneC = 1 To compteurC
                If Cells(ligneC, 1) = patientA Then
                    test = 1
                End If
            Next
            
            If test > 0 Then
                Exit For
            Else
                Cells(compteurC, 1) = patientA
            End If
                
                
                Exit For
            
        Exit For
        End If
    Next
Next
End Sub

Désolé pour l'indentation un peu pourrie j'y suis allé un peu a la schlag :)

Bon app !

cindy001 · Answer

Merci Ta macro Morgothal marche très bien

Merci à toi aussi eriic de m'avoir lu

RechercheV

3 réponses

Discussions similaires

Newsletters