Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Bens7

XLDnaute Impliqué
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)
 

Pièces jointes

  • SOURCE.zip
    17.6 KB · Affichages: 39

chezswan

XLDnaute Occasionnel
Bonjour,

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

Swan
 

Pièces jointes

  • Copie de monfichier.xlsm
    19.9 KB · Affichages: 27

youky(BJ)

XLDnaute Barbatruc
Bonjour tous,
Voici une macro à mettre en Module
J'ai pris Feuil1 c'est le codename de l'onglet donc à modifier si besoin.
Bruno
VB:
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
 
Dernière édition:

youky(BJ)

XLDnaute Barbatruc
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
VB:
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

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

VB:
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 !!
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Un autre essai ?:
VB:
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

XLDnaute Impliqué
 

Bens7

XLDnaute Impliqué
On peux pas juste readapter le Macro suivant :

VB:
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)

XLDnaute Barbatruc
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
VB:
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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…