bonjour,
un tout petit adaption, de manière qu'il ne faut plus changer ce numéro
Sub aargh2()
Dim Mots
ReDim Mots(600000, 0) '<------------------
Mots(0, 0) = "données"
Set dict = CreateObject("scripting.dictionary")
For Each ws In ActiveWorkbook.Sheets
With ws
If .Name <> "summary" Then
ReDim Preserve Mots(UBound(Mots), UBound(Mots, 2) + 1) '<------------------
jeu = jeu + 1
Mots(0, jeu) = .Name
dl = .Cells(Rows.Count, 1).End(xlUp).Row
t = .Range("A1").Resize(dl, 1)
For i = 1 To UBound(t)
cle = .Cells(i, 1).Value
If dict.exists(cle) Then
ptr = dict(cle)
Else
ctr = ctr + 1
dict(cle) = ctr
ptr = ctr
End If
Mots(ptr, 0) = cle
Mots(ptr, jeu) = "x"
Next i
End If
End With
Next
With Sheets("summary")
.Cells.Delete
.Range("A1").Resize(ctr + 1, jeu + 1) = Mots
.Cells(2, jeu + 2).Resize(ctr, 1).FormulaR1C1 = "=countif(rc2:rc" & jeu & ",""x"")"
.Cells(2, jeu + 2).Resize(ctr, 1).Value = .Cells(2, jeu + 2).Resize(ctr, 1).Value
.Cells(1, jeu + 2) = "presence"
.ListObjects.Add(xlSrcRange, .Range("A1").Resize(ctr + 1, jeu + 2), xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight9"
End With
End Sub