Discussion :

[jeremie84]

Bonjour à tous,

le casse tête du jour. J'ai un classeur contenant X feuilles.
dans chaque feuilles j'ai une colonne nom et une prénom. et d'autre mais qui n'ont pas d'utilité pour cette macro

Je souhaite sur une feuille "recap" noter tous les noms trouvés avec en face tous les noms de feuilles ou ce nom a été trouvé.

Je joint le fichier avec le resultat attendu car je pense pas avoir été très clair dans mon explication.

Merci d'avance de votre aide.

[EngueEngue]

Fait rapidement, devrait gazer, à toi de l'adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub toto()
Dim sh As Worksheet
k = 2
'copie tous dans recap
For Each sh In Worksheets
If sh.Name <> "Recap" Then
For i = 2 To sh.Range("A" & sh.Rows.Count).End(xlUp).Row
Sheets("Recap").Cells(k, 1) = sh.Cells(i, 1)
Sheets("Recap").Cells(k, 2) = sh.Cells(i, 2)
Sheets("Recap").Cells(k, 3) = sh.Name
k = k + 1
Next i
End If
Next sh
 
'trier
ActiveWorkbook.Worksheets("Recap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Recap").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Recap").Sort
.SetRange Range("A2:C200000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
 
'Mets tous dans une ligne
With Sheets("Recap")
For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
If .Range("A" & i) = .Range("A" & i - 1) And .Range("B" & i) = .Range("B" & i - 1) Then
j = 1
While .Cells(i, j) <> ""
j = j + 1
Wend
For k = 4 To j
.Cells(i - 1, k) = .Cells(i, k - 1)
Next k
.Rows(i).Delete
 
End If
 
Next i
End With
 
End Sub

[vinc_bilb]

Par exemple (même si je pense que passer par une collection serait plus concis)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 
Sub Build_recap()
' Dev versuib, Without Error mgmt and clean comments !
 
Dim Wsh As Worksheet
Dim Data_exp() As Variant
Dim Data_rec As Integer, Data_ind As Integer
Dim Coln As Long, Rown As Long, MaxCol As Integer
Dim InpRng As Range
Dim FoundNam As Boolean
 
    ' Get the max records to proceed to set the dimension of Data_exp array
For Each Wsh In ThisWorkbook.Worksheets
 
    If Wsh.UsedRange.Rows.Count > Data_rec And Wsh.Name <> "Recap" Then
        Data_rec = Wsh.UsedRange.Rows.Count 'To be changed if it's not coherent
    End If
 
Next Wsh
 
    ' Redim according to the number of worksheets and names
ReDim Data_exp(1 To Data_rec + 2, 1 To ThisWorkbook.Worksheets.Count + 3)
MaxCol = UBound(Data_exp, 2)
 
    ' Parse all the sheets except thee Recap and build an arrat
Data_rec = 0
 
For Each Wsh In ThisWorkbook.Worksheets
 
    If Wsh.Name <> "Recap" Then
 
        Set InpRng = Wsh.Range("A2").CurrentRegion
 
            For Rown = 2 To InpRng.Rows.Count
 
                FoundNam = False
 
                For Data_ind = 1 To Data_rec
 
                    If Data_exp(Data_ind, 1) = InpRng(Rown, 1) And Data_exp(Data_ind, 2) = InpRng(Rown, 2) Then
 
                        FoundNam = True
                        Data_exp(Data_ind, MaxCol) = Data_exp(Data_ind, MaxCol) + 1
                        Data_exp(Data_ind, Data_exp(Data_ind, MaxCol) + 2) = Wsh.Name
 
                    End If
 
                Next Data_ind
 
                If FoundNam = False Then        ' Record not found, create it in the array
 
                    Data_rec = Data_rec + 1
                    Data_exp(Data_rec, 1) = InpRng(Rown, 1)
                    Data_exp(Data_rec, 2) = InpRng(Rown, 2)
                    Data_exp(Data_ind, MaxCol) = Data_exp(Data_ind, MaxCol) + 1
                    Data_exp(Data_ind, Data_exp(Data_ind, MaxCol) + 2) = Wsh.Name
 
                End If
 
            Next Rown
 
    End If
 
Next Wsh
 
    'Report
Worksheets("Recap").Activate
Cells.Clear
 
For Rown = 1 To Data_rec
    For Coln = 1 To MaxCol - 1
        Cells(Rown, Coln) = Data_exp(Rown, Coln)
    Next Coln
Next Rown
 
 
End Sub

[Marc-L]

même si je pense que passer par une collection serait plus concis

Tu m'étonnes !

[jeremie84]

J'ai choisi celui de EngueEngue plus compréhensible pour moi et mon petit niveau en VBA et ça fonctionne pas mal. Je l'ai adapté à mes feuilles.

J'ai que la mise sur une ligne qui ne se fait pas et je ne vois pas pourquoi à mon avis c'est que les noms prénoms ne doivent pas être exactement tapé pareil d'une feuille à l'autre car sur certains noms ça fonctionne à peut prêt et sur d'autres pas du tout.