Extraction mot(s) en commun dans tableau
Bonjour,
j'extrais des données d'un tableur et le résultat est obtenu sous la forme d'une suite de mois et je voudrais extraire dans une cellule les mois commun entre les différentes lignes
Qui a une solution pour moi ?
Merci
Merci Jean-Eric mais je ne vais pas savoir adapter à mes feuilles... Aujourd'hui j'ai environ 40 feuilles ou je souhaite appliquer ce filtre et 90-100 au final donc j'aurais préféré en macro ou en vba....
Salut Akhlan
Salut Jean-Eric,
un double-clic sur la feuille démarre la macro avec affichage en [C1].
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, tSplit, tRep, iNb%, iRep%, sRep$, sScan$
Cancel = True
'
tTab = Range("A1").Resize(Range("A" & Rows.Count).End(xlUp).Row, 1).Value
For x = 1 To UBound(tTab, 1)
If tTab(x, 1) <> "" Then
tSplit = Split(tTab(x, 1), "-")
For y = 0 To UBound(tSplit)
If InStr(sScan, tSplit(y)) = 0 Then
iRep = 1
sScan = sScan & IIf(sScan = "", tSplit(y), "-" & tSplit(y))
For Z = x + 1 To UBound(tTab, 1)
If tTab(Z, 1) <> "" Then
If x = 1 And y = 0 Then iNb = iNb + 1
If InStr(tTab(Z, 1), tSplit(y)) > 0 Then iRep = iRep + 1
End If
Next
End If
If x = 1 And y = 0 Then iNb = iNb + 1
If iRep = iNb Then sRep = sRep & IIf(sRep = "", tSplit(y), "-" & tSplit(y))
Next
Exit For
End If
Next
[C1] = sRep
'
End SubPour appliquer à l'ensemble des feuilles, il faudrait savoir si :
- TOUTES les feuilles doivent être traitées, sans exception ;
- si non, comment reconnaître les feuilles à traiter (particularité dans leur nom ?) ;
- à quel emplacement exact faut-il afficher le résultat.
A+
Salut Akhlan,
Salut Jean-Eric,
corrections..
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, tSplit, iOK%, iNb%, iRep%, sRep$, sScan$
Cancel = True
'
iNb = 1
tTab = Range("A1").Resize(Range("A" & Rows.Count).End(xlUp).Row, 1).Value
For x = 1 To UBound(tTab, 1)
If tTab(x, 1) <> "" Then
iOK = iOK + 1
tSplit = Split(tTab(x, 1), "-")
For y = 0 To UBound(tSplit)
If InStr(sScan, tSplit(y)) = 0 Then
iRep = 1
sScan = sScan & IIf(sScan = "", tSplit(y), "-" & tSplit(y))
For Z = x + 1 To UBound(tTab, 1)
If tTab(Z, 1) <> "" Then
If iOK = 1 And y = 0 Then iNb = iNb + 1
If InStr(tTab(Z, 1), tSplit(y)) > 0 Then iRep = iRep + 1
End If
Next
End If
If iRep = iNb Then sRep = sRep & IIf(sRep = "", tSplit(y), "-" & tSplit(y))
Next
Exit For
End If
Next
[C1] = sRep
'
End Sub
A+
Salut Jean-Eric, curulis57, Akhlan
une autre proposition que je travail sur depuis ....Vendredi
elle peut générer même une liste de occurrences !
Sub test()
Dim Strg
ReDim Strg(0)
Drnl = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Stor(0)
ReDim NxStor(0)
NxStor(0) = 0
For x = 1 To Drnl 'XXXX
If Cells(x, 1) <> "" Then
tbl = Split(Cells(x, 1), "-")
For v = 0 To UBound(tbl)
n = 0
For j = v To UBound(tbl)
ReDim Preserve Strg(n)
Strg(n) = tbl(j)
t = Join(Strg, "-")
n = n + 1
If n > 1 Then
For i = x + 1 To Drnl
If InStr(Cells(i, 1), t) > 0 And Cells(i, 1) <> "" Then
'----#####----
g = True
For z = 0 To UBound(Stor)
If t = Stor(z) Then
Stor(z) = t
NxStor(z) = NxStor(z) + 1
g = False
Exit For
End If
Next z
If g = True Then
ReDim Preserve Stor(l)
ReDim Preserve NxStor(l)
Stor(l) = t
NxStor(l) = 1
l = l + 1
End If
'----#####----
End If
Next i
End If
Next j
Next v
End If
Next x
If l > 0 Then
h = Application.Max(NxStor)
f = Application.Match(h, NxStor, 0) - 1
Cells(, "D").EntireColumn.ClearContents
For m = 0 To UBound(Stor)
If NxStor(m) = h Then
p = p + 1
Cells(p, "D") = Stor(m)
End If
Next m
End If
End SubMerci à tout le monde,
Amir, désolé ta version ne fonctionne pas pour ce que je recherche mais merci tout de même ;)
J'ai opté pour la version de curulis57 qui correspond parfaitement à mes besoins ;)