Re : plantage Macro sur version excel
Re,
Le fait de sortir des onglets du tableau perturbe le fonctionnement de la macro, en ne sortant que le minimum (3 Onglets) je suis encore trop lourd je ne peux pas mettre le fichier en ligne.
le bug a été déclenché quand j'ai ajouté des lignes dans le l'onglet janvier.
ci dessous la macro, mais je pense que cela ne sert à rien sans le reste si on pouvait passer par un site genre dropbox ce serai plus simple
merci en tout cas a vous de vous intéresser à mon grave Pb j'ai perdu des mois de travail
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(, 32).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 >= 32 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 >= 32
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.[C41:N46].Value
Range("G13:O14").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[-6]C[-4]=0,"""",(VLOOKUP(R[-6]C[-4],Tables!R[-10]C[27]:R[97]C[28],2,FALSE)))"
Range("G13:O14").Select
Range("AC10").Select
Selection.Copy
Range("G22:Q24").Select
ActiveSheet.Paste
End Sub