Compter des occurrences et écrire les détails dans un fichier texte
4 réponses
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
'------------------------------- 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
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 '---------------------------------------------------
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:=False
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
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
'---------------------------------------------------
'------------------------------- 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
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 '---------------------------------------------------