Microsoft 365 VBA pour copier/coller une plage de cellule dans un autre onglet en fonction de la date

Sylvain. B

XLDnaute Nouveau
Bonjour à toute la communauté,

J'aimerais faire en sorte qu'une plage de cellules se situant de C9 à S9 de la feuille 1 appelée "CA" soit copiée/collée dans un autre onglet en fonction de la date qui se trouve en A7 de la feuille "CA", dans chaque onglets mensuels les dates se situent en colonne B.
Il faudrait parcourir chacun des onglets du classeur (hors feuille "CA") et copier ces cellules sur la ligne correspondante à cette date toujours de la colonne C à la colonne S.

Pourriez-vous m'aider s'il vous plaît ?
Je vous joins un exemple pour mieux comprendre car il me semble que je ne suis pas très clair🫣

Merci à toutes et tous pour votre aide et/ou vos idées.

J'ai commencé en écrivant le code ci-dessous mais je débute et j'ai du mal à terminer ou même à le faire fonctionner avec mon niveau de connaissance :

Sub CopierCollerDansChaqueOnglet()

'Déclaration des variables
Dim feuilleCA As Worksheet
Dim feuilleMensuel As Worksheet
Dim dateCopier As Date
Dim ligneCopier As Integer
Dim onglet As Worksheet

'Définition de la feuille de travail CA
Set feuilleCA = ThisWorkbook.Sheets("CA")

'Récupération de la date à partir de la cellule A7 de la feuille CA
dateCopier = feuilleCA.Range("A7").Value

'Parcours de chaque feuille de travail
For Each onglet In ThisWorkbook.Worksheets

'Vérification si la feuille est différente de la feuille CA
If Not onglet.Name = feuilleCA.Name Then

'Recherche de la ligne correspondante dans l'onglet courant
'Définition de la plage de recherche (ici colonne A)
Set plageRecherche = onglet.Range("B:B")

'Recherche de la valeur dans la plage de recherche
Set resultat = plageRecherche.Find(What:=recherche, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)

'Copie des cellules de C2 à S2 dans la ligne correspondante de l'onglet courant
feuilleCA.Range("C2:S2").Copy Destination:=onglet.Range("C" & ligneCopier)

End If

Next onglet

End Sub
 

Pièces jointes

  • Exemple collecte CA et marge par division.xlsx
    198.1 KB · Affichages: 5
Solution
Bonjour Sylvain. B,

La macro affectée au bouton :
VB:
Sub Copier()
Dim dat As Variant, P As Range, i As Long
With Sheets("CA")
    dat = .[A7]
    If Not IsDate(dat) Then Exit Sub
    dat = CLng(CDate(dat))
    Set P = .[D3:T3]
End With
On Error Resume Next
With Sheets(Format(dat, "mmmm"))
    If Err Then MsgBox "Feuille " & UCase(Format(dat, "mmmm")) & " inexistante !", 48: Exit Sub
    i = Application.Match(dat, .[B:B], 0)
    If i = 0 Then MsgBox "Date introuvable !", 48: Exit Sub
    .Cells(i, 3).Resize(, P.Columns.Count) = P.Value 'copier-coller des valeurs
    Application.Goto .Cells(i, 2) 'selection facultative
End With
End Sub
A+

Sylvain. B

XLDnaute Nouveau
Bonjour Sylvain. B,

En feuille "CA' je vois la plage C3:R3 mais il n'y a rien en C9:S9, que faut-il donc faire ?

A+
Bonjour Job75,

En effet, autant pour moi, désolé.
La plage de données à copier/coller se situe en D3:T3 de la feuille "CA".
J'ai légèrement modifié l'exemple pour qu'il soit plus clair enfin je l’espère.

Merci à vous, excellente journée.
 

Pièces jointes

  • Exemple collecte CA et marge par division.xlsx
    199.7 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour Sylvain. B,

La macro affectée au bouton :
VB:
Sub Copier()
Dim dat As Variant, P As Range, i As Long
With Sheets("CA")
    dat = .[A7]
    If Not IsDate(dat) Then Exit Sub
    dat = CLng(CDate(dat))
    Set P = .[D3:T3]
End With
On Error Resume Next
With Sheets(Format(dat, "mmmm"))
    If Err Then MsgBox "Feuille " & UCase(Format(dat, "mmmm")) & " inexistante !", 48: Exit Sub
    i = Application.Match(dat, .[B:B], 0)
    If i = 0 Then MsgBox "Date introuvable !", 48: Exit Sub
    .Cells(i, 3).Resize(, P.Columns.Count) = P.Value 'copier-coller des valeurs
    Application.Goto .Cells(i, 2) 'selection facultative
End With
End Sub
A+
 

Pièces jointes

  • Exemple collecte CA et marge par division.xlsm
    207.2 KB · Affichages: 12

Sylvain. B

XLDnaute Nouveau
Bonjour Sylvain. B,

La macro affectée au bouton :
VB:
Sub Copier()
Dim dat As Variant, P As Range, i As Long
With Sheets("CA")
    dat = .[A7]
    If Not IsDate(dat) Then Exit Sub
    dat = CLng(CDate(dat))
    Set P = .[D3:T3]
End With
On Error Resume Next
With Sheets(Format(dat, "mmmm"))
    If Err Then MsgBox "Feuille " & UCase(Format(dat, "mmmm")) & " inexistante !", 48: Exit Sub
    i = Application.Match(dat, .[B:B], 0)
    If i = 0 Then MsgBox "Date introuvable !", 48: Exit Sub
    .Cells(i, 3).Resize(, P.Columns.Count) = P.Value 'copier-coller des valeurs
    Application.Goto .Cells(i, 2) 'selection facultative
End With
End Sub
A+
Bonjour Job75,

Ça fonctionne parfaitement, vous êtes au top :)
Merci beaucoup pour votre aide, vraiment je vais gagner pas mal de temps grâce à vous.
Je vous souhaite une excellente journée et vous remercie infiniment.
 

Discussions similaires

Réponses
2
Affichages
110

Statistiques des forums

Discussions
312 103
Messages
2 085 313
Membres
102 860
dernier inscrit
fredo67