Compter des occurrences et écrire les détails dans un fichie
Bonjour à tous,
Dans mon classeur, j'ai deux boutons.
1) Le premier bouton sert à calculer, depuis la colonne A, des occurrences selon des plages inscrites dans la colonne J.
Dans celui-ci, j'aimerais ajouter un code pour écrire dans un fichier texte, les détails de chaque intitulé (Colonne I) et de chacune de ces plages (Colonne J).
L'exemple du fichier texte à obtenir est dans la PJ.
2) le deuxième bouton, sert à calculer le nombre total des occurrences par intitulé et de l'ensemble de ces plages, comme indique dans le tableau en F:G.
Seulement, le résultat n'est pas bon comme espérer dans la Feuil2!F:G
Merci d’avance.
Bonjour
Pour ce qui est de la feuille2
Une formule en G2 incrémentée vers le bas
=SOMMEPROD((Feuil1!$F$2:$F$500=F2)*(Feuil1!$G$2:$G$500))donne le résulat
Cordialement
Bonsoir Amadéus,
J'aimerais bien que le code VBA soit corrigé
Parce que les colonnes F et G sont obtenues depuis les tableaux "C:D" et "I:J"
Voila la correction de ma macro CompteIntit :
Sub CompteIntit()
Dim i&
Dim LgNom As Range, Trouvé As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If [F2] <> "" Then
Range("F2:G" & Range("G" & Rows.Count).End(xlUp).Row).ClearContents
End If
For i = 2 To Range("C" & Rows.Count).End(xlUp).Row
Set LgNom = Range("J2:J" & Range("J" & Rows.Count).End(xlUp).Row) _
.Find(Range("C" & i))
If Not LgNom Is Nothing Then
Set Trouvé = Range("F2:F" & Range("G" & Rows.Count).End(xlUp).Row) _
.Find(Range("I" & LgNom.Row))
If Not Trouvé Is Nothing Then
Range("G" & Trouvé.Row) = Range("G" & Trouvé.Row) + Range("D" & i)
Range("G" & Trouvé.Row).Select
Else
Cells(Range("F" & Rows.Count).End(xlUp).Row, "F").Offset(1, 0) = Range("I" & LgNom.Row)
Cells(Range("F" & Rows.Count).End(xlUp).Row, "F").Offset(0, 1) = Range("D" & i)
End If
Else
MsgBox Range("C" & i) & " Pas trouvée dans la plage = " & _
Range("J2:J" & Range("J" & Rows.Count).End(xlUp).Row).Address
End If
Next
Range("F1:G65000").Sort Key1:=Range("G1"), Order1:=xlAscending, Header:=xlGuess
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End SubReste comment obtenir le fichier texte des détails voulu
Merci.
Voila une deuxième version, avec test d'une méthode pour écrire dans un fichier texte.
Mais le code bug lorsqu'il doit scinder une plage [xx-yy] en deux extrémités dans la fonction extreme() !
Bonjour
A partant de ta macro (ta avais fais le max du boulot)
J'utilise une feuille supplémentaire pour stockage provisoire
Bonjour Banzai64,
Merci pour la rectification.
Et je vois que tu as éliminé l'utilisation du tableau Tb().
Il me servira, surtout pour le gain du temps en cas de plusieurs lignes de données.
Bonjour
apt a écrit :Et je vois que tu as éliminé l'utilisation du tableau Tb().
Cela c'est fait par la force des choses, et je ne crois pas qu'il y ait un gain important de la vitesse
A vérifier soigneusement
Bonsoir Banzai64,
Voila un code utilisant les tableaux.
Avec l'écriture/lecture depuis la feuille 4, ça dure 1.20 sec.
Avec l'écriture/lecture depuis un tableau, ça dure 0.9 sec.
Sub Details()
Dim DLA As Integer, DLF As Integer, DLI As Integer, DLM As Integer
Dim Cel As Range
Dim Tb() As Variant, Tmp
Dim entete As Boolean
Dim Ligne As Long
Dim Ik As Long
Dim LgTotal As Long
Dim Total As Long
Dim Nff As Byte, Pth As String, Txt(), TxtF()
Dim oS1 As Worksheet
Dim oS4 As Worksheet
Dim FcNm As String, i As Long, Rw1 As Long, NLn As Long, Rw2 As Long, j As Long
Dim StartTimer, EndTimer
StartTimer = Timer
Application.ScreenUpdating = False
Set oS1 = Worksheets("Feuil1"): Set oS4 = Worksheets("Feuil4")
Pth = ThisWorkbook.Path: Nff = FreeFile: FcNm = "LIC LIBRE (" & Nff & ").txt"
Rw1 = oS1.Cells(Rows.Count, 1).End(xlUp).Row: If Rw1 = 1 Then Exit Sub
oS4.Cells.Clear
With oS1
If [L2] <> "" Then
.Range("L2:M" & .Range("L" & Rows.Count).End(xlUp).Row).ClearContents
End If
DLA = .Range("A" & Rows.Count).End(xlUp).Row
DLF = .Range("F" & Rows.Count).End(xlUp).Row
DLI = .Range("I" & Rows.Count).End(xlUp).Row
For Each Cel In .Range("F2:F" & DLF)
[O2] = Cel
.Range("I1:J" & DLI).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("O1:O2"), _
CopyToRange:=.Range("L1:M1"), Unique:=False
DLM = .Range("M" & Rows.Count).End(xlUp).Row ' Tu n'auras jamais 0
entete = False
Total = 0
LgTotal = 0
If DLM > 1 Then
For i = 2 To DLM
Tmp = Extreme(.Range("M" & i)) 'ICI ERREUR : incompatibile de type
If IsArray(Tmp) Then
If entete = False Then
ReDim Preserve Txt(1 To Ligne + 3)
Ligne = Ligne + 1: Txt(Ligne) = "----------------------------------------------------"
Ligne = Ligne + 1: Txt(Ligne) = "Intitulé : " & .Range("L" & i)
Ligne = Ligne + 1: Txt(Ligne) = "Total"
LgTotal = Ligne
entete = True
End If
.Range("A1:A" & DLA).AutoFilter Field:=1, Criteria1:=">=" & Tmp(0), _
Operator:=xlAnd, Criteria2:="<=" & Tmp(1)
TxtF = .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible) 'Copy
ReDim Preserve Txt(1 To Ligne + 3)
Ligne = Ligne + 1: Txt(Ligne) = ""
Ligne = Ligne + 1: Txt(Ligne) = "Plage" & vbTab & vbTab & vbTab & "Bloc" & vbTab & vbTab & "Total"
Ligne = Ligne + 1: Txt(Ligne) = .Range("M" & i) & vbTab & vbTab & i - 2 & vbTab & vbTab & vbTab & UBound(Txt)
ReDim Preserve Txt(1 To Ligne + UBound(TxtF))
For Ik = 1 To UBound(TxtF)
Ligne = Ligne + 1
Txt(Ligne) = TxtF(Ik, 1)
Next Ik
Total = Total + UBound(Txt)
.ShowAllData
End If
Next i
If LgTotal > 0 Then
Txt(LgTotal) = "Total : " & Total
End If
End If
Next Cel
End With
Call WriteNLine(Txt, FcNm, Pth, Nff)
Set oS1 = Nothing: Set oS4 = Nothing
EndTimer = Timer - StartTimer
MsgBox " temps : " & EndTimer
[H11] = EndTimer
End Sub
Private Function Extreme(ByVal Str As String)
Str = Replace(Replace(Str, "[", ""), "]", "")
If InStr(Str, "-") Then Extreme = Split(Str, "-")
End Function
Sub WriteNLine(vStr(), vFnm As String, vPth As String, vNff As Byte)
Dim i As Long, vWL As String
Open vPth & "\" & vFnm For Append As #vNff 'Output As #vNff
i = 1
Do
Print #vNff, vStr(i)
i = i + 1
Loop Until i > UBound(vStr) 'NbRw
Close #vNff
End SubBonsoir
C'est vrai 3/10 de secondes c'est important
Mais vu la macro (car je ne fais que lire dans la page (au lieu du tableau) je ne le pensais pas que l'on pouvait gagner
Mais je viens de voir les résultats de ta macro, on n'a pas les mêmes
Edit: Oui le tableau remplace la page et dedans il y a des opérations d'écriture (cause du ralentissement)
L'erreur vient de ces lignes
Ligne = Ligne + 1: Txt(Ligne) = .Range("M" & i) & vbTab & vbTab & i - 2 & vbTab & vbTab & vbTab & UBound(TxtF)
ReDim Preserve Txt(1 To Ligne + UBound(TxtF))
For Ik = 1 To UBound(TxtF)
Ligne = Ligne + 1
Txt(Ligne) = TxtF(Ik, 1)
Next Ik
Total = Total + UBound(TxtF)Oui il fallait mettre TxtF.
Maintenant pour éviter une erreur lors d'un résulat nulle dans le filtre automatique, j'ai ajouté un test sur le nombre des lignes visibles :
Nbf = .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Count
If Nbf > 1 Then
'MsgBox "Addr Special : " & .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Address
TxtF = .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible) Mais j'ai une erreur :
Incompatibilté de type
dans la derniere ligne
Bonsoir
Pas de plantage chez moi
Même fichier ?
Il faut que tu le joignes
La version 003 en PJ.
Bonjour
Plantage quand 1 seule donnée
Je ne sais pas si c'est la solution , mais cela fonctionne
If Nbf > 1 Then
If Nbf = 2 Then
ReDim TxtF(1 To 1, 1 To 1)
TxtF(1, 1) = .Range("A2:A" & DLA).SpecialCells(xlCellTypeVisible)
Else
TxtF = .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible)
End If
'.
'.
'.Bonjour Banzai64,
Ça marche comme solution.
Merci.