XL 2010 résolus

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
N

n_turf

XLDnaute Nouveau
bonjour ,
voila , j'ai fait appel à une AI ( Claude) afin de m'aider à créer se fichier concernant les courses de chevaux mais , buggs récurant , en fait dés qu'il touche à quelques choses cela met en vrille autres choses et du coup j'ai perd des mois d'archivages , bref du temps etc etc ....
dernierement je me suis appercus que l'archivage ne se faisait pas correctement concernant les pages " réunion " , a priori seul la page " Réunion 3 " se fait correctement , je dit bien à priori ...malheuresement je ne peut pas télécharger ici le fichier ( trop volumineux ) , donc je vous copie le code VBA qui peut étre sera vous renseigner sur l'erreur ....

VB: 
' ================================================================
' MODULE : ModuleArchivage v4 - Archivage COMPLET
' ================================================================
Sub SauvegarderFichier()
    ThisWorkbook.Save
End Sub
Sub ArchiverReunion1()
    Call ArchiverReunion("Réunion1", "Réunion 1")
End Sub
Sub ArchiverReunion2()
    Call ArchiverReunion("Réunion2", "Réunion 2")
End Sub
Sub ArchiverReunion3()
    Call ArchiverReunion("Réunion3", "Réunion 3")
End Sub
Sub ReinitReunion1()
    Call ReinitReunion("Réunion1")
End Sub
Sub ReinitReunion2()
    Call ReinitReunion("Réunion2")
End Sub
Sub ReinitReunion3()
    Call ReinitReunion("Réunion3")
End Sub
Sub ArchiverReunion(nomFeuille As String, labelReunion As String)
    Dim wsR As Worksheet, wsH As Worksheet
    Dim nextRow As Long, synRow As Long
    Dim courseRow As Long, ptRow As Long
    Dim nbArchives As Integer, i As Integer
    On Error GoTo ErrHandler
    ThisWorkbook.Save
    Set wsR = ThisWorkbook.Sheets(nomFeuille)
    Set wsH = ThisWorkbook.Sheets("Historique")
    wsH.Unprotect Password:=""
    nextRow = wsH.Cells(wsH.Rows.Count, "A").End(xlUp).Row + 1
    If nextRow < 4 Then nextRow = 4
    nbArchives = 0
    For synRow = 6 To 42 Step 4
        courseRow = synRow - 2
        ptRow = synRow - 1
        If wsR.Cells(courseRow, 3).Value = "" Then GoTo NextCourse
        wsH.Cells(nextRow, 1).Value = wsR.Cells(synRow, 11).Value
        wsH.Cells(nextRow, 2).Value = wsR.Cells(1, 4).Value
        wsH.Cells(nextRow, 3).Value = wsR.Cells(1, 6).Value
        wsH.Cells(nextRow, 4).Value = labelReunion
        wsH.Cells(nextRow, 5).Value = wsR.Cells(courseRow - 1, 1).Value
        wsH.Cells(nextRow, 6).Value = wsR.Cells(courseRow, 3).Value
        wsH.Cells(nextRow, 7).Value = wsR.Cells(courseRow, 4).Value
        wsH.Cells(nextRow, 8).Value = wsR.Cells(courseRow, 15).Value
        wsH.Cells(nextRow, 9).Value = wsR.Cells(courseRow, 16).Value
        wsH.Cells(nextRow, 10).Value = wsR.Cells(courseRow, 17).Value
        wsH.Cells(nextRow, 11).Value = wsR.Cells(courseRow, 18).Value
        wsH.Cells(nextRow, 12).Value = wsR.Cells(ptRow, 15).Value
        wsH.Cells(nextRow, 13).Value = wsR.Cells(ptRow, 17).Value
        wsH.Cells(nextRow, 14).Value = wsR.Cells(synRow, 15).Value
        wsH.Cells(nextRow, 15).Value = wsR.Cells(synRow, 16).Value
        wsH.Cells(nextRow, 16).Value = wsR.Cells(synRow, 17).Value
        wsH.Cells(nextRow, 17).Value = wsR.Cells(synRow, 21).Value
        wsH.Cells(nextRow, 18).Value = wsR.Cells(synRow, 22).Value
        wsH.Cells(nextRow, 19).Value = wsR.Cells(synRow, 23).Value
        wsH.Cells(nextRow, 20).Value = wsR.Cells(synRow, 24).Value
        wsH.Cells(nextRow, 21).Value = wsR.Cells(synRow, 26).Value
        wsH.Cells(nextRow, 22).Value = wsR.Cells(synRow, 27).Value
        wsH.Cells(nextRow, 23).Value = wsR.Cells(synRow, 28).Value
        wsH.Cells(nextRow, 24).Value = wsR.Cells(synRow, 29).Value
        wsH.Cells(nextRow, 25).Value = wsR.Cells(synRow, 30).Value
        wsH.Cells(nextRow, 26).Value = wsR.Cells(synRow, 31).Value
        wsH.Cells(nextRow, 27).Value = wsR.Cells(synRow, 32).Value
        wsH.Cells(nextRow, 28).Value = wsR.Cells(synRow, 33).Value
        wsH.Cells(nextRow, 29).Value = wsR.Cells(synRow, 34).Value
        wsH.Cells(nextRow, 30).Value = wsR.Cells(synRow, 35).Value
        wsH.Cells(nextRow, 31).Value = wsR.Cells(synRow, 36).Value
        wsH.Cells(nextRow, 32).Value = wsR.Cells(synRow, 37).Value
        wsH.Cells(nextRow, 33).Value = wsR.Cells(synRow, 38).Value
        wsH.Cells(nextRow, 34).Value = wsR.Cells(ptRow, 19).Value
        wsH.Cells(nextRow, 35).Value = wsR.Cells(ptRow, 22).Value
        wsH.Cells(nextRow, 36).Value = wsR.Cells(synRow, 19).Value
        wsH.Cells(nextRow, 37).Value = wsR.Cells(synRow, 22).Value
        For i = 1 To 8
            wsH.Cells(nextRow, 37 + i).Value = wsR.Cells(courseRow, 2 + i).Value
        Next i
        For i = 1 To 8
            wsH.Cells(nextRow, 45 + i).Value = wsR.Cells(ptRow, 2 + i).Value
        Next i
        For i = 1 To 8
            wsH.Cells(nextRow, 53 + i).Value = wsR.Cells(synRow, 2 + i).Value
        Next i
        nbArchives = nbArchives + 1
        nextRow = nextRow + 1
NextCourse:
    Next synRow
    wsH.Protect Password:=""
    If nbArchives > 0 Then
        MsgBox nbArchives & " course(s) archivee(s) !", vbInformation, "Archivage OK"
    Else
        MsgBox "Aucune donnee a archiver.", vbExclamation, "Rien a archiver"
    End If
    Exit Sub
ErrHandler:
    wsH.Protect Password:=""
    MsgBox "Erreur : " & Err.Description, vbCritical, "Erreur archivage"
End Sub
Sub ReinitReunion(nomFeuille As String)
    If MsgBox("Effacer toutes les saisies de " & nomFeuille & " ?", vbYesNo + vbQuestion, "Confirmer") = vbNo Then Exit Sub
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(nomFeuille)
    ws.Unprotect Password:=""
    Dim r As Long
    For r = 4 To 40 Step 4
        ws.Range(ws.Cells(r, 3), ws.Cells(r, 10)).ClearContents
        ws.Range(ws.Cells(r + 1, 3), ws.Cells(r + 1, 10)).ClearContents
        ws.Cells(r, 15).ClearContents
        ws.Cells(r, 16).ClearContents
        ws.Cells(r, 17).ClearContents
        ws.Cells(r, 18).ClearContents
        ws.Cells(r + 1, 15).ClearContents
        ws.Cells(r + 1, 16).ClearContents
        ws.Cells(r + 1, 19).ClearContents
        ws.Cells(r + 2, 19).ClearContents
    Next r
    Call RestaurerSyntheses(ws)
    ws.Protect Password:=""
    MsgBox nomFeuille & " reinitialisee !", vbInformation, "OK"
End Sub
Sub RestaurerSyntheses(ws As Worksheet)
    Dim syn As Long, col As Long, idx As Integer
    Dim zt As Long, pt As Long
    For syn = 6 To 42 Step 4
        zt = syn - 2: pt = syn - 1
        For col = 3 To 10
            idx = col - 2
            ws.Cells(syn, col).Formula = _
                "=IFERROR(IF(ISNUMBER(MATCH(LARGE(AT" & syn & ":BJ" & syn & "," & idx & "),AT" & syn & ":BA" & syn & ",0))," & _
                "INDEX(C" & zt & ":J" & zt & ",MATCH(LARGE(AT" & syn & ":BJ" & syn & "," & idx & "),AT" & syn & ":BA" & syn & ",0))," & _
                "INDEX(C" & pt & ":J" & pt & ",MATCH(LARGE(AT" & syn & ":BJ" & syn & "," & idx & "),BB" & syn & ":BI" & syn & ",0))),"""")"
        Next col
        ws.Cells(zt, 12).Formula = "=IF(C" & syn & "="""","""",C" & syn & ")"
        ws.Cells(zt, 13).Formula = "=IF(D" & syn & "="""","""",D" & syn & ")"
    Next syn
End Sub
Sub ArchiverQuinte()
    Dim wsQ As Worksheet, wsAQ As Worksheet
    Dim nextRow As Long, j As Integer
    On Error GoTo ErrHandler
    ThisWorkbook.Save
    Set wsQ = ThisWorkbook.Sheets("Quinté+")
    Set wsAQ = ThisWorkbook.Sheets("Archive Quinté")
    nextRow = wsAQ.Cells(wsAQ.Rows.Count, "A").End(xlUp).Row + 1
    If nextRow < 2 Then nextRow = 2
    If wsQ.Cells(2, 2).Value = "" Then
        MsgBox "Aucun prono saisi dans Quinté+", vbExclamation, "Rien a archiver"
        Exit Sub
    End If
    For j = 1 To 8
        wsAQ.Cells(nextRow, j).Value = wsQ.Cells(2, 1 + j).Value
    Next j
    For j = 1 To 8
        wsAQ.Cells(nextRow, 8 + j).Value = wsQ.Cells(3, 1 + j).Value
    Next j
    For j = 1 To 8
        wsAQ.Cells(nextRow, 16 + j).Value = wsQ.Cells(4, 1 + j).Value
    Next j
    For j = 1 To 8
        wsAQ.Cells(nextRow, 24 + j).Value = wsQ.Cells(5, 1 + j).Value
    Next j
    wsAQ.Cells(nextRow, 33).Value = wsQ.Cells(8, 4).Value
    wsAQ.Cells(nextRow, 34).Value = wsQ.Cells(8, 5).Value
    wsAQ.Cells(nextRow, 35).Value = wsQ.Cells(8, 6).Value
    wsAQ.Cells(nextRow, 36).Value = wsQ.Cells(8, 7).Value
    wsAQ.Cells(nextRow, 37).Value = wsQ.Cells(8, 8).Value
    MsgBox "Quinté+ archivé ! Ligne " & nextRow & ".", vbInformation, "Archivage OK"
    Exit Sub
ErrHandler:
    MsgBox "Erreur : " & Err.Description, vbCritical, "Erreur archivage"
End Sub
Sub GenererTicketQuinte()
    Dim wsQ As Worksheet
    Set wsQ = ThisWorkbook.Sheets("Quinté+")
    wsQ.Calculate
    MsgBox "Ticket généré !", vbInformation, "Ticket Quinté+"
End Sub




merci d'avance
 
Dernière modification par un modérateur:
Trier par date Trier par votes
remplacer la macro "ArchiverReunion..." par ceci
Le problème, c'est que la cellule K de chaque 3ième ligne est vide, je ne sais pas pourquoi.

VB: 
Sub ArchiverReunion(nomFeuille As String, labelReunion As String)
     Dim wsR As Worksheet, wsH As Worksheet, Temp
     Dim nextRow As Long, synRow As Long
     Dim courseRow As Long, ptRow As Long
     Dim nbArchives As Integer, i As Integer
     'On Error GoTo ErrHandler
     ThisWorkbook.Save
     Set wsR = ThisWorkbook.Sheets(nomFeuille)
     Set wsH = ThisWorkbook.Sheets("Historique")
     With wsH
          .Unprotect Password:=""
          On Error Resume Next
          .AutoFilter.Range.AutoFilter
          On Error GoTo 0
          nextRow = wsH.Cells(wsH.Rows.Count, "A").End(xlUp).Row + 1
     End With
     If nextRow < 4 Then nextRow = 4
     nbArchives = 0
     For synRow = 6 To 42 Step 4
          courseRow = synRow - 2
          ptRow = synRow - 1
          If wsR.Cells(courseRow, 3).Value = "" Then GoTo NextCourse
          Temp = wsR.Cells(synRow, 11).Value
          If Len(Temp) = 0 Then Temp = "???, " & nomFeuille & " cellule K" & synRow & " est vide"
          wsH.Cells(nextRow, 1).Value = Temp
          wsH.Cells(nextRow, 2).Value = wsR.Cells(1, 4).Value
          wsH.Cells(nextRow, 3).Value = wsR.Cells(1, 6).Value
          wsH.Cells(nextRow, 4).Value = labelReunion
          wsH.Cells(nextRow, 5).Value = wsR.Cells(courseRow - 1, 1).Value
          wsH.Cells(nextRow, 6).Value = wsR.Cells(courseRow, 3).Value
          wsH.Cells(nextRow, 7).Value = wsR.Cells(courseRow, 4).Value
          wsH.Cells(nextRow, 8).Value = wsR.Cells(courseRow, 15).Value
          wsH.Cells(nextRow, 9).Value = wsR.Cells(courseRow, 16).Value
          wsH.Cells(nextRow, 10).Value = wsR.Cells(courseRow, 17).Value
          wsH.Cells(nextRow, 11).Value = wsR.Cells(courseRow, 18).Value
          wsH.Cells(nextRow, 12).Value = wsR.Cells(ptRow, 15).Value
          wsH.Cells(nextRow, 13).Value = wsR.Cells(ptRow, 17).Value
          wsH.Cells(nextRow, 14).Value = wsR.Cells(synRow, 15).Value
          wsH.Cells(nextRow, 15).Value = wsR.Cells(synRow, 16).Value
          wsH.Cells(nextRow, 16).Value = wsR.Cells(synRow, 17).Value
          wsH.Cells(nextRow, 17).Value = wsR.Cells(synRow, 21).Value
          wsH.Cells(nextRow, 18).Value = wsR.Cells(synRow, 22).Value
          wsH.Cells(nextRow, 19).Value = wsR.Cells(synRow, 23).Value
          wsH.Cells(nextRow, 20).Value = wsR.Cells(synRow, 24).Value
          wsH.Cells(nextRow, 21).Value = wsR.Cells(synRow, 26).Value
          wsH.Cells(nextRow, 22).Value = wsR.Cells(synRow, 27).Value
          wsH.Cells(nextRow, 23).Value = wsR.Cells(synRow, 28).Value
          wsH.Cells(nextRow, 24).Value = wsR.Cells(synRow, 29).Value
          wsH.Cells(nextRow, 25).Value = wsR.Cells(synRow, 30).Value
          wsH.Cells(nextRow, 26).Value = wsR.Cells(synRow, 31).Value
          wsH.Cells(nextRow, 27).Value = wsR.Cells(synRow, 32).Value
          wsH.Cells(nextRow, 28).Value = wsR.Cells(synRow, 33).Value
          wsH.Cells(nextRow, 29).Value = wsR.Cells(synRow, 34).Value
          wsH.Cells(nextRow, 30).Value = wsR.Cells(synRow, 35).Value
          wsH.Cells(nextRow, 31).Value = wsR.Cells(synRow, 36).Value
          wsH.Cells(nextRow, 32).Value = wsR.Cells(synRow, 37).Value
          wsH.Cells(nextRow, 33).Value = wsR.Cells(synRow, 38).Value
          wsH.Cells(nextRow, 34).Value = wsR.Cells(ptRow, 19).Value
          wsH.Cells(nextRow, 35).Value = wsR.Cells(ptRow, 22).Value
          wsH.Cells(nextRow, 36).Value = wsR.Cells(synRow, 19).Value
          wsH.Cells(nextRow, 37).Value = wsR.Cells(synRow, 22).Value
          For i = 1 To 8
               wsH.Cells(nextRow, 37 + i).Value = wsR.Cells(courseRow, 2 + i).Value
          Next i
          For i = 1 To 8
               wsH.Cells(nextRow, 45 + i).Value = wsR.Cells(ptRow, 2 + i).Value
          Next i
          For i = 1 To 8
               wsH.Cells(nextRow, 53 + i).Value = wsR.Cells(synRow, 2 + i).Value
          Next i
          nbArchives = nbArchives + 1
          nextRow = nextRow + 1
NextCourse:
     Next synRow
     wsH.Protect Password:=""
     If nbArchives > 0 Then
          MsgBox nbArchives & " course(s) archivee(s) !", vbInformation, "Archivage " & nomFeuille & " OK"
     Else
          MsgBox "Aucune donnee a archiver.", vbExclamation, nomFeuille & ", Rien a archiver"
     End If
     Exit Sub
ErrHandler:
     wsH.Protect Password:=""
     MsgBox "Erreur : " & Err.Description, vbCritical, nomFeuille & ", Erreur archivage"
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

C
  • Résolu(e)
XL 2019 User Form qui renvoi dans un tableau avec celulle fusionnée
2
Réponses
16
Affichages
257
Piment
P
N
  • Question Question
Listbox click
Réponses
10
Affichages
647
ChTi160
ChTi160
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
801
KRUG WOO
K
F
  • Question Question
XL 2021 probleme dans la macro
Réponses
4
Affichages
716
kiki29
kiki29
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
1 K
telemarrk
T
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
690
vgendron
vgendron
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
445
CDALE
C
U
  • Question Question
Autres [RÉSOLU] macro à modifier
Réponses
1
Affichages
607
un internaute
U
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
851
piga25
piga25
lestoiles1
  • Question Question
XL 2013 Sub commentaire
Réponses
2
Affichages
399
lestoiles1
lestoiles1
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
4 K
saidoush
S
G
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
892
GClaire
G
B
  • Résolu(e)
Microsoft 365 creation d'liste à imprimer
2 3 4
Réponses
51
Affichages
3 K
Banbara
B
S
  • Question Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
649
souhaib ad
S
D
  • Question Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
2 K
AtTheOne
AtTheOne
G
  • Question Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
19
Affichages
2 K
GClaire
G
D
  • Question Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
3 K
Dranreb
Dranreb
G
  • Question Question
Microsoft 365 Export données d'une listview
Réponses
5
Affichages
740
GClaire
G
M
  • Question Question
Microsoft 365 modifier un code
Réponses
1
Affichages
536
Dranreb
Dranreb
G
  • Question Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
871
GClaire
G
Retour