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

Bens7 · 8 Mars 2018

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 · 9 Mars 2018

Bens7 à dit:
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 · 9 Mars 2018

Bonjour Swan

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

youky(BJ) · 9 Mars 2018

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

Lone-wolf · 9 Mars 2018

Bonjour Bruno

Nickel, comme d'habitude.

youky(BJ) · 9 Mars 2018

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

Lone-wolf · 9 Mars 2018

Bonsoir Bruno

Joli jeu de mots

youky(BJ) · 10 Mars 2018

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 · 26 Juin 2018

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 !!

mapomme · 27 Juin 2018

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 · 23 Juillet 2018

mapomme à dit:

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 · 23 Juillet 2018

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 · 23 Juillet 2018

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) · 23 Juillet 2018

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

Bens7 · 24 Juillet 2018

Merci mais j'ai :
Erreur de Syntaxe :

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

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

Bens7

XLDnaute Impliqué

Pièces jointes

chezswan

XLDnaute Occasionnel

Pièces jointes

Lone-wolf

XLDnaute Barbatruc

youky(BJ)

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

youky(BJ)

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

youky(BJ)

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

mapomme

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

youky(BJ)

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

Discussions similaires