Bonjour à tous,
un des brillants membre qui composent se forum m'a trouver la macro pour créer un CMA automatique, j'ai perdu le lien et ne me souvient plus de son nom, le tableau fonctionne à merveille mais il ignore le "31" du mois quelque soit le mois.
je mets la macro ci dessous et une extrac du tableau en croisant les doigts pour croiser de nouveau celui qui avait écrit la macro ou quelqu'un qui puisse m'aider.
merci a vous
Sub Collecte(ByVal FCbl As Worksheet)
Dim FSrc As Worksheet, Cel As Range, Déb As Date, Te(), Codes(), Périodes(), DCV As New Dictionary, _
Valide As Boolean, L As Long, J As Long, Jp As Long, CodCou As String, CodSui As String
On Error Resume Next
Set FSrc = ThisWorkbook.Worksheets(FCbl.[AD4].Value)
If Err Then MsgBox "Feuille """ & FCbl.[AD4].Value & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
Te = FCbl.Range("U2:U" & FCbl.[U500].End(xlUp).Row).Value
For L = 1 To UBound(Te)
If Not IsEmpty(Te(L, 1)) Then DCV(UCase(Te(L, 1))) = 0
Next L
Déb = FSrc.[C8].Value - 1
Set Cel = FSrc.[A9:A88].Find(What:=FCbl.[C7].Value, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Cel Is Nothing Then MsgBox Feuil109.[C7].Value & " inexistant.", vbCritical, "Collecte": Exit Sub
Te = Cel.Offset(, 2).Resize(, 31).Value
ReDim Codes(1 To 19, 1 To 1), Périodes(1 To 19, 1 To 2)
L = 0: J = 1: CodSui = UCase(Te(1, 1))
Do ' Début code
CodCou = CodSui: Valide = DCV.Exists(CodCou)
If Valide Then L = L + 1: Codes(L, 1) = CodCou: Périodes(L, 1) = Format(Déb + J, "dd mmm yyyy")
Do: If J >= 31 Then Exit Do
J = J + 1: CodSui = UCase(Te(1, J)): Loop Until CodSui <> CodCou
' Fin code
If Valide Then Périodes(L, 2) = Format(Déb + J - 1, "dd mmm yyyy")
Loop Until J >= 31
FCbl.[A13].Resize(19, 1).Value = Codes
FCbl.[C13].Resize(19, 2).Value = Périodes
Dim Nom As String, NomFeui As String, FeuiNom As Worksheet
Nom = FCbl.[C7].Value
NomFeui = "Nom " & (Cel.Row - 9) \ 2 + 1
On Error Resume Next
Set FeuiNom = ThisWorkbook.Worksheets(NomFeui)
If Err Then MsgBox "Feuille """ & NomFeui & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
If FeuiNom.[B5].Value <> Nom Then MsgBox "Attention, " & NomFeui & "!B5 contient """ & _
FeuiNom.[B5].Value & """ au lieu de """ & Nom & """.", vbExclamation, "Collecte"
FCbl.[G35:R40].Value = FeuiNom.[C40:N45].Value
End Sub
un des brillants membre qui composent se forum m'a trouver la macro pour créer un CMA automatique, j'ai perdu le lien et ne me souvient plus de son nom, le tableau fonctionne à merveille mais il ignore le "31" du mois quelque soit le mois.
je mets la macro ci dessous et une extrac du tableau en croisant les doigts pour croiser de nouveau celui qui avait écrit la macro ou quelqu'un qui puisse m'aider.
merci a vous
Sub Collecte(ByVal FCbl As Worksheet)
Dim FSrc As Worksheet, Cel As Range, Déb As Date, Te(), Codes(), Périodes(), DCV As New Dictionary, _
Valide As Boolean, L As Long, J As Long, Jp As Long, CodCou As String, CodSui As String
On Error Resume Next
Set FSrc = ThisWorkbook.Worksheets(FCbl.[AD4].Value)
If Err Then MsgBox "Feuille """ & FCbl.[AD4].Value & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
Te = FCbl.Range("U2:U" & FCbl.[U500].End(xlUp).Row).Value
For L = 1 To UBound(Te)
If Not IsEmpty(Te(L, 1)) Then DCV(UCase(Te(L, 1))) = 0
Next L
Déb = FSrc.[C8].Value - 1
Set Cel = FSrc.[A9:A88].Find(What:=FCbl.[C7].Value, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Cel Is Nothing Then MsgBox Feuil109.[C7].Value & " inexistant.", vbCritical, "Collecte": Exit Sub
Te = Cel.Offset(, 2).Resize(, 31).Value
ReDim Codes(1 To 19, 1 To 1), Périodes(1 To 19, 1 To 2)
L = 0: J = 1: CodSui = UCase(Te(1, 1))
Do ' Début code
CodCou = CodSui: Valide = DCV.Exists(CodCou)
If Valide Then L = L + 1: Codes(L, 1) = CodCou: Périodes(L, 1) = Format(Déb + J, "dd mmm yyyy")
Do: If J >= 31 Then Exit Do
J = J + 1: CodSui = UCase(Te(1, J)): Loop Until CodSui <> CodCou
' Fin code
If Valide Then Périodes(L, 2) = Format(Déb + J - 1, "dd mmm yyyy")
Loop Until J >= 31
FCbl.[A13].Resize(19, 1).Value = Codes
FCbl.[C13].Resize(19, 2).Value = Périodes
Dim Nom As String, NomFeui As String, FeuiNom As Worksheet
Nom = FCbl.[C7].Value
NomFeui = "Nom " & (Cel.Row - 9) \ 2 + 1
On Error Resume Next
Set FeuiNom = ThisWorkbook.Worksheets(NomFeui)
If Err Then MsgBox "Feuille """ & NomFeui & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
If FeuiNom.[B5].Value <> Nom Then MsgBox "Attention, " & NomFeui & "!B5 contient """ & _
FeuiNom.[B5].Value & """ au lieu de """ & Nom & """.", vbExclamation, "Collecte"
FCbl.[G35:R40].Value = FeuiNom.[C40:N45].Value
End Sub