1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
| Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'Application.ScreenUpdating = False
Dim e As Integer
Dim rep As Date
Dim fin As Integer
Dim i As Long
Dim TableauC As Variant
Dim tabloC As Variant
Dim TableC() As Variant
Dim t As Integer
'------------- Limite de dates 12 mois glissants -----------------
If TextBox1.Value = "" Then
rep = CDate(Date)
Else
rep = CDate(TextBox1)
End If
TextBox1.Value = DateSerial(Year(rep), Month(rep), 1)
rep = TextBox1.Value
deb = DateSerial(Year(rep), (Month(rep)) - 12, 1)
'------------------ Fin de limite dates --------------------------
'--------------- Créations des tableaux clients ------------------
With Sheets("nc_client")
fin = .Range("a65535").End(xlUp).Row
For i = 5 To fin
If .Cells(i, 1).Value >= deb Then
DebTaC = i
Exit For
End If
Next
For i = fin To 4 Step -1
If .Cells(i, 1) <= rep Then
FinTaC = i
Exit For
End If
Next
TableauC = .Range("a" & DebTaC & ":b" & FinTaC)
tabloC = .Range("b" & DebTaC & ":b" & FinTaC)
End With
'----------- Fin de Créations des tableaux clients --------------
'------- Filtrage des clients ---- Ouskel'n'or ------------------
With Sheets("temp")
.Range("a:a").ClearContents
.Range("a1:a" & FinTaC - DebTaC + 1).Value = tabloC
.Range("a1:a" & FinTaC - DebTaC + 1).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("B1:b" & FinTaC - DebTaC + 1), Unique:=True
Set Plage = .Range("a1:a" & FinTaC - DebTaC + 1).SpecialCells(xlCellTypeVisible)
Erase tabloC
t = 0
For Each Cell In Plage
ReDim Preserve tabloC(t)
tabloC(t) = Cell
t = t + 1
Next
.ShowAllData
End With
'-------- Fin de filtrage et remaniment du tableau liste --------
'---------------- creation du tabeau de feuille -----------------
For t = 0 To UBound(tabloC)
ReDim Preserve TableC(UBound(tabloC), 0)
TableC(t, 0) = tabloC(t)
For i = 14 To 1 Step -1
For x = 1 To UBound(TableauC, 1)
ReDim Preserve TableC(UBound(tabloC), i)
If TableC(t, 0) = TableauC(x, 2) And DateAdd("m", (-i + 2), rep) = TableauC(x, 1) Then
nb = nb + 1
End If
TableC(t, i) = nb
Next
nb = 0
Next
Next
With Sheets("temp")
.Range("a:n").ClearContents
.Range("a1:n" & UBound(tabloC) + 1).Value = TableC
End With
Unload Me
End Sub |
Partager