XL 2019 Convertir des données à la suite d'une liste

[SEBCRESP]

Bonjour à toutes et tous,
Je me permets de solliciter votre aide pour réaliser en automatique une action que j'ai besoin de réaliser hebdomadairement.
En effet chaque semaine, je copie des données dans les premiers onglets "Rapport hebdomadaire" ayant un format prédéfini.
Mon but serait d'avoir un bouton "actualiser" dans le deuxième onglet "liste des appels mensuels" qui copierait à la suite de la liste déjà existante les données sous le format de cette dernière liste.

Je joins un fichier Excel d'exemple à ce message.

Merci de tous ceux qui voudront bien m'aider à trouver une solution simple qui me permettrait de gagner beaucoup de temps.

Cordialement,

SEB

 

[sylvanu]

Bonsoir Sdumas, et bienvenu sur XLD,
Un essai en PJ avec :

Public T, Madate
Sub Transfert()
    Dim L%, i%
    T = [A1].CurrentRegion
    L = 1 + Sheets("liste des appels mensuels").Range("A65500").End(xlUp).Row
    With Sheets("liste des appels mensuels")
        For i = 2 To UBound(T)
            If IsDate(T(i, 1)) Then
                Madate = T(i, 1)
                i = i + 1: InsererLigne L, i
                L = L + 1: i = i + 4
            Else
                i = i - 1: InsererLigne L, i
                L = L + 1: i = i + 3
            End If
            If i > UBound(T) Then Exit Sub
        Next i
    End With
End Sub
Sub InsererLigne(L, i)
    Dim N%
    With Sheets("liste des appels mensuels")
        .Cells(L, 1) = Madate
        For N = 2 To 5
            .Cells(L, N) = T(i + N - 2, 1)
        Next N
    End With
End Sub

Mais il faut respecter la structure 4 lignes par appel.

 

[SEBCRESP]

Les 4 lignes sont toujours respectées et avec l'exemple fourni c'est juste parfait !

Pour autant, j'abuse un peu car le nombre d'appel par jour et le jour nombre de jour d'appel peuvent être aléatoires et dans ces cas j'ai le sentiment que ca bug !
En pièces jointes le bug et un autre exemple avec plus d'appel et plus de jour d'appel

PS : plusieurs appel sur un même établissement poseraient problème ?

Merci encore

 

[sylvanu]

Bonsoir,
Joli bug, et vicieux. Lié aux pointeurs décalés.
PJ corrigée ... enfin je pense.
Sorry.

 

[sylvanu]

Re,
Bien confus comme code avec tous ces décalages de pointeurs.
Une PJ plus propre avec :

Sub Transfert()
    Dim L%, i%, T, Td, Madate: On Error GoTo Fin
    T = [A1].CurrentRegion
    ReDim Td(1 To UBound(T))
    For i = 1 To UBound(T)      ' Met 1 à chaque date de T, sinon 0
        If IsDate(T(i, 1)) Then Td(i) = 1 Else Td(i) = 0
    Next i
    L = 1 + Sheets("liste des appels mensuels").Range("A65500").End(xlUp).Row
    With Sheets("liste des appels mensuels")
        For i = 2 To UBound(T)
            If Td(i) = 1 Then Madate = T(i, 1)
            While Td(i) = 0
                .Cells(L, 1) = Madate
                For N = 2 To 5
                    .Cells(L, N) = T(i + N - 2, 1)
                 Next N
                L = L + 1: i = i + 4
                If Td(i) = 1 Then Madate = T(i, 1)
            Wend
        Next i
    End With
Fin:
End Sub

 

[SEBCRESP]

Re,
Bien confus comme code avec tous ces décalages de pointeurs.
Une PJ plus propre avec :

Sub Transfert()
    Dim L%, i%, T, Td, Madate: On Error GoTo Fin
    T = [A1].CurrentRegion
    ReDim Td(1 To UBound(T))
    For i = 1 To UBound(T)      ' Met 1 à chaque date de T, sinon 0
        If IsDate(T(i, 1)) Then Td(i) = 1 Else Td(i) = 0
    Next i
    L = 1 + Sheets("liste des appels mensuels").Range("A65500").End(xlUp).Row
    With Sheets("liste des appels mensuels")
        For i = 2 To UBound(T)
            If Td(i) = 1 Then Madate = T(i, 1)
            While Td(i) = 0
                .Cells(L, 1) = Madate
                For N = 2 To 5
                    .Cells(L, N) = T(i + N - 2, 1)
                 Next N
                L = L + 1: i = i + 4
                If Td(i) = 1 Then Madate = T(i, 1)
            Wend
        Next i
    End With
Fin:
End Sub

C'est parfait ! tout semble bien fonctionner.
Merci infiniment !