Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Compter des occurrences et écrire les détails dans un fichier texte

4 réponses
Avatar
Apitos
Bonjour =E0 tous,
=20
Dans mon classeur, j'ai deux boutons.
=20
1) Le premier bouton sert =E0 calculer, depuis la colonne A, des occurrence=
s selon des plages inscrites dans la colonne J.
=20
Dans celui-ci, j'aimerais ajouter un code pour =E9crire dans un fichier tex=
te, les d=E9tails de chaque intitul=E9 (Colonne I) et de chacune de ces pla=
ges (Colonne J).
=20
L'exemple du fichier texte =E0 obtenir est dans la PJ.
=20
2) le deuxi=E8me bouton, sert =E0 calculer le nombre total des occurrences =
par intitul=E9 et de l'ensemble de ces plages, comme indique dans le tablea=
u en F:G.
=20
Seulement, le r=E9sultat n'est pas bon comme esp=E9rer dans la Feuil2!F:G

http://cjoint.com/?BKjpNqEuTkA

Merci d=92avance.

4 réponses

Avatar
Apitos
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(xlU p).Row) _
.Find(Range("I" & LgNom.Row))

If Not Trouvé Is Nothing Then
Range("G" & Trouvé.Row) = Range("G" & Trouvé.Row) + R ange("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).Add ress
End If
Next

Range("F1:G65000").Sort Key1:=Range("G1"), Order1:=xlAscending, Hea der:=xlGuess

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
'---------------------------------

Reste comment obtenir le fichier texte des détails voulu ;)

Merci.
Avatar
Apitos
Bonjour,

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émi tés dans la fonction extreme() !

http://cjoint.com/?BKkiAjrV3kk
Avatar
Apitos
Deuxième version avec le fichier texte :

http://cjoint.com/?BKkpNzrRe8N
Avatar
Apitos
Bonsoir,

Voila une solution :

'-------------------------------
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 Nbf 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 = "LN LIBRE (" & Nf f & ").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).ClearCo ntents
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, Cri teriaRange:=.Range("O1:O2"), _
CopyToRange:=.Range("L1:M 1"), Unique:lse

DLM = .Range("M" & Rows.Count).End(xlUp).Row
entete = False
Total = 0
LgTotal = 0
If DLM > 1 Then
For i = 2 To DLM
Tmp = Extreme(.Range("M" & i))
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, Criteri a1:=">=" & Tmp(0), _
Operator:=xlAnd, Criteria2:="<=" & Tmp(1)
Nbf = .Range("A1").CurrentRegion.Offset(1, 0).Spe cialCells(xlCellTypeVisible).Count
If Nbf > 1 Then
If Nbf = 2 Then
ReDim TxtF(1 To 1, 1 To 1)
TxtF(1, 1) = .Range("A2:A" & DLA).Special Cells(xlCellTypeVisible)
Else
TxtF = .Range("A1").CurrentRegion.Offset( 1, 0).SpecialCells(xlCellTypeVisible)
End If
ReDim Preserve Txt(1 To Ligne + 3)
Ligne = Ligne + 1: Txt(Ligne) = ""
Ligne = Ligne + 1: Txt(Ligne) = "Plage" & v bTab & vbTab & vbTab & "Bloc" & vbTab & vbTab & "Total"
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)
End If
.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 Output As #vNff
i = 1
Do
Print #vNff, vStr(i)
i = i + 1
Loop Until i > UBound(vStr)
Close #vNff
End Sub
'---------------------------------------------------