XL 2010 Nmb de fois le nom d'un fichier dans un tableaux

[Bens7]

Bonjour a tous !!
Alors voila après avoir chercher plusieurs option (Google+Forum)
je me tourne vers vous :

- J'ai un dossier comportant des logs (enfait des fichier txt vide) (voir dossier : /RESEAUX/EN COURS)
exemple: Tomate1.txt ; Tomate6.txt; Tomate3.txt

- Et dans mon tableau je voudrais calculer le nombre de fois ou un produit existe en log.
exemple: "Tomate" = 3 (il y a 3 fichier comportant le mot "Tomate" dans le dossier)

Voila je vous est mis un petit dossier + un FAKE bouton pour éclaircir :

P.S: Mon fichier réel comporte en fait plus de 300 lignes repartie sur 9 catégorie...donc plus de 4000 mot a tester léger au max...si possible.

Merci d'avance novice VBA (adaptation minimum)

 

[chezswan]

Bonjour a tous !!
Alors voila après avoir chercher plusieurs option (Google+Forum)
je me tourne vers vous :

- J'ai un dossier comportant des logs (enfait des fichier txt vide) (voir dossier : /RESEAUX/EN COURS)
exemple: Tomate1.txt ; Tomate6.txt; Tomate3.txt

- Et dans mon tableau je voudrais calculer le nombre de fois ou un produit existe en log.
exemple: "Tomate" = 3 (il y a 3 fichier comportant le mot "Tomate" dans le dossier)

Voila je vous est mis un petit dossier + un FAKE bouton pour éclaircir :

P.S: Mon fichier réel comporte en fait plus de 300 lignes repartie sur 9 catégorie...donc plus de 4000 mot a tester léger au max...si possible.

Merci d'avance novice VBA (adaptation minimum)

Bonjour,

Voir si la formule dans la cellule surlignée en jaune convient.

Swan

 

[Lone-wolf]

Bonjour Swan

Ce n'est pas ce que demande Bens7. Lit comme il faut.

 

[youky(BJ)]

Bonjour tous,
Voici une macro à mettre en Module
J'ai pris Feuil1 c'est le codename de l'onglet donc à modifier si besoin.
Bruno

Sub faitboulot()
rep = ThisWorkbook.Path & "\RESEAUX\EN COURS\"
fichier = Dir(rep)
Do While fichier <> ""
  tx = Left(fichier, Len(fichier) - 4)
For k = 1 To Len(tx)
If Not IsNumeric(Mid(tx, Len(tx) - k, 1)) Then
tx1 = Left(tx, Len(tx) - k): n = Replace(tx, tx1, "")
Exit For
End If
Next
  Set c = Feuil1.UsedRange.Find(tx1, LookIn:=xlValues)
  If Not c Is Nothing Then
  c.Offset(0, 1) = c.Offset(0, 1)+val(n)
  End If
  fichier = Dir
Loop
End Sub

 

[Lone-wolf]

Bonjour Bruno

Nickel, comme d'habitude.

 

[youky(BJ)]

Bonjour Lone-Wolf
Cela me va droit-au-cœur hihi!

 

[Lone-wolf]

Bonsoir Bruno

Joli jeu de mots

 

[youky(BJ)]

Bonjour Tous,
Il y a encore une solution, c'est pas d'additionner les chiffres en fin de noms de fichier mais simplement compter le nbre de fichier Carotte ou autres.
Dans ce cas voici la macro.
Attention si c'est la 1ère macro qui est utilisée il faut rectifier la ligne >>>Set c...... comme dans cette macro pour trouver la valeur exact
Exemple Courge et Courgette, il pouvait trouver Courge dans Courgette.
Bruno

Sub fake()
rep = ThisWorkbook.Path & "\RESEAUX\EN COURS\"
fichier = Dir(rep)
Do While fichier <> ""
  tx = Left(fichier, Len(fichier) - 4)
For k = 1 To Len(tx)
If Not IsNumeric(Mid(tx, Len(tx) - k, 1)) Then
tx = Left(tx, Len(tx) - k)
Exit For
End If
Next
  Set c = Feuil1.UsedRange.Find(tx, lookat:=xlWhole)
  If Not c Is Nothing Then
  c.Offset(0, 1) = Val(c.Offset(0, 1)) + 1
  End If
  fichier = Dir
Loop
End Sub

 

[Bens7]

Bonjour navre de ne pas être revenu sur le post pour remercier !!
cela fonctionne parfaitement voici mon code actuel :

Sub majlegume()

rep = "D:\MON DOSSIER\RESEAUX\EN COURS\"
fichier = Dir(rep)
Do While fichier <> ""
  tx = Left(fichier, Len(fichier) - 4)
For k = 1 To Len(tx)
If Not IsNumeric(Mid(tx, Len(tx) - k, 1)) Then
tx = Left(tx, Len(tx) - k)
Exit For
End If
Next
  Set C = Feuil2.UsedRange.Find(tx, lookat:=xlWhole)
  If Not C Is Nothing Then
  C.Offset(0, 1) = Val(C.Offset(0, 1)) + 1
  End If
  fichier = Dir
Loop
End Sub

Alors je me permet juste une petite modification suite a une insertion de fichier en copier coller :
J;ai bien de fichier :
Tomate1
Tomate2
Tomate3
Qui sont bien calcule .. mais j'ai aussi (suite a un copier coller (obligatoire)provenant d'un autre dossier):
Tomate1
Tomate1 (2)
Tomate1 (3)
Tomate2
Tomate2 (2)
Tomate2 (3)
Tomate3
Tomate3 (2)
Tomate3 (3)
donc j'ai besoin que ceux avec parenthèse soit comptabiliser également... merci pour vos lumières !!

 

[mapomme]

Bonsoir à tous,

Un autre essai ?:

Private Sub CommandButton1_Click()
Dim dico, T, i&, j&
Dim F(), chemin, fichier, cat

Set dico = CreateObject("scripting.dictionary")
dico.CompareMode = TextCompare
T = Worksheets("Feuil1").Range("a1").CurrentRegion
For i = 2 To UBound(T)
   For j = 1 To 5 Step 2
      If T(i, j) <> "" Then dico(T(i, j)) = 0
   Next j
Next i

chemin = ThisWorkbook.Path & "\RESEAUX\EN COURS\"
chemin = Replace(chemin, "\\", "\")
fichier = Dir(chemin & "*.txt")
Do Until fichier = ""
   fichier = Left(fichier, Len(fichier) - 4)
   For Each cat In dico.Keys
      If fichier Like cat & "#" & "*" Then dico(cat) = dico(cat) + 1
   Next cat
   fichier = Dir
Loop

For i = 2 To UBound(T)
   For j = 1 To 5 Step 2
      If T(i, j) <> "" Then T(i, j + 1) = dico(T(i, j))
   Next j
Next i
Worksheets("Feuil1").Range("a1").CurrentRegion = T
End Sub

 

[Bens7]

Bonsoir à tous,

Un autre essai ?:

Private Sub CommandButton1_Click()
Dim dico, T, i&, j&
Dim F(), chemin, fichier, cat

Set dico = CreateObject("scripting.dictionary")
dico.CompareMode = TextCompare
T = Worksheets("Feuil1").Range("a1").CurrentRegion
For i = 2 To UBound(T)
   For j = 1 To 5 Step 2
      If T(i, j) <> "" Then dico(T(i, j)) = 0
   Next j
Next i

chemin = ThisWorkbook.Path & "\RESEAUX\EN COURS\"
chemin = Replace(chemin, "\\", "\")
fichier = Dir(chemin & "*.txt")
Do Until fichier = ""
   fichier = Left(fichier, Len(fichier) - 4)
   For Each cat In dico.Keys
      If fichier Like cat & "#" & "*" Then dico(cat) = dico(cat) + 1
   Next cat
   fichier = Dir
Loop

For i = 2 To UBound(T)
   For j = 1 To 5 Step 2
      If T(i, j) <> "" Then T(i, j + 1) = dico(T(i, j))
   Next j
Next i
Worksheets("Feuil1").Range("a1").CurrentRegion = T
End Sub

 

[Bens7]

L'indice n'appartient pas a la selection :
If T(i, j) <> "" Then
Mon fichier test est dans : D:\MONDOSSIER\SOUSDOSSIER\test.xlsm
Mes fichiers text sont dans : D:\MONDOSSIER\RESEAUX\EN COURS\

 

[Bens7]

On peux pas juste readapter le Macro suivant :

Sub majlegume()

rep = "D:\MON DOSSIER\RESEAUX\EN COURS\"
fichier = Dir(rep)
Do While fichier <> ""
  tx = Left(fichier, Len(fichier) - 4)
For k = 1 To Len(tx)
If Not IsNumeric(Mid(tx, Len(tx) - k, 1)) Then
tx = Left(tx, Len(tx) - k)
Exit For
End If
Next
  Set C = Feuil2.UsedRange.Find(tx, lookat:=xlWhole)
  If Not C Is Nothing Then
  C.Offset(0, 1) = Val(C.Offset(0, 1)) + 1
  End If
  fichier = Dir
Loop
End Sub

Et je n'aurais qu'a change mes fichier text l'hors de la creation en mettant un espace après le mot exact du genre :
Tomate 1
Tomate 2
Tomate 3
Tomate 1 (2)
Tomate 1 (3)
Tomate 2
Tomate 2 (2)
Tomate 2 (3)
Tomate 3
Tomate 3 (2)
Tomate 3 (3)
Dans ce cas on calcule le nmb de fois "Tomate" uniquement peux importe la suite ...
P.,S : Attentons au cas Courge et Courgette par exemple comme la dit youky-bj plus haut.

 

[youky(BJ)]

Bonjour à tous,
Attention je viens de faire cette macro avec le Bloc Note donc je n'ai rien testé.
En plus si j'ai compris.
Bruno

Sub majlegume()
rep = "D:\MON DOSSIER\RESEAUX\EN COURS\"
fichier = Dir(rep)
Do While fichier <> ""
  tx = split(fichier," ")(0)
  Set C = Feuil2.UsedRange.Find(tx, lookat:=xlWhole)
If Not C Is Nothing Then
if right(C.value,1)=")" then
  tx2=split(fichier,"(")(1)
  n=left(tx2,len(tx2)-5)
   C.Offset(0, 1))=replace(C.Offset(0, 1),"(" & n & ")","(" & n+1 & ")")
else
  C.Offset(0, 1) = Val(C.Offset(0, 1)) + 1
end if
End If
  fichier = Dir
Loop
End Sub

 

[Bens7]

Merci mais j'ai :
Erreur de Syntaxe :


C.Offset(0, 1))=replace(C.Offset(0, 1),"(" & n & ")","(" & n+1 & ")")