XL 2013 copier coller en vba

M

michokette

XLDnaute Nouveau
Bonjour

J'extrais d'un logiciel de facturation un classeur excel (classeur1.xlsx)
Je fais actuellement un copier coller manuel de ce classeur, dans le classeur stat.xlsx, et ce, pour chaque produits (collecte, ventes contenants...ect)
Je souhaiterai faire cela par une macro (sachant que j'ai une dizaine de tableau du mème style à faire)
Pour information les données à copier du classeur1 ne se trouvent pas forcement à la ligne 9, cela peut varier.
En vous remerciant par avance de vos contributions
 

Pièces jointes

  • Classeur1.xlsx
    12.6 KB · Affichages: 16
  • STAT.xlsx
    95.8 KB · Affichages: 12
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour michokette,

Téléchargez les 2 fichiers joints dans le même dossier (le bureau).

Modifiez les données du fichier source Classeur1.xlsx (y compris l'année) et testez ces 2 macros :
VB: 
Sub MAJ_Mois()
'se lance par les touches Ctrl+M
If MsgBox("Etes-vous sûr qu'il faut mettre à jour les mois ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Dim source$, w As Worksheet, c As Range, c1 As Range
source = ThisWorkbook.Path & "\Classeur1.xlsx" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(source).Sheets(1)
    For Each w In ThisWorkbook.Worksheets
        Set c = .Cells.Find(Replace(w.Name, " ", "*") & "*", , xlValues, xlWhole)
        If Not c Is Nothing Then
            Set c1 = w.Cells.Find("Qté N")
            If Not c1 Is Nothing Then c1(1, 2).Resize(, 12) = c(2, 2).Resize(, 12).Value
            Set c1 = w.Cells.Find("C A N")
            If Not c1 Is Nothing Then c1(1, 2).Resize(, 12) = c(3, 2).Resize(, 12).Value
        End If
    Next
    .Parent.Close True
End With
End Sub

Sub Nouvelle_Annee()
If MsgBox("Etes-vous sûr qu'il faut créer une nouvelle année ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Dim source$, w As Worksheet, c As Range, c1 As Range, n%, c2 As Range
source = ThisWorkbook.Path & "\Classeur1.xlsx" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(source).Sheets(1)
    Set c = .Cells.Find("FamilleArticle", , xlValues, xlWhole)
    If Not c Is Nothing Then
        For Each w In ThisWorkbook.Worksheets
            Set c1 = w.Cells.Find("FamilleArticle")
            If Not c1 Is Nothing Then
                n = n + 1
                If n = 1 Then If Year(c(1, 3)) = Year(c1(1, 2)) Then MsgBox "Modifiez l'année du fichier source !", 48: Exit Sub
                w.Cells.Find("FamilleArticle", c1)(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12) = c(1, 3).Resize(, 12).Value
            End If
            Set c1 = w.Cells.Find("Qté N")
            If Not c1 Is Nothing Then
                Set c2 = w.Cells.Find("Qté N*-*")
                If Not c2 Is Nothing Then c2(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12).ClearContents
            End If
            Set c1 = w.Cells.Find("C A N")
            If Not c1 Is Nothing Then
                Set c2 = w.Cells.Find("C A N*-*")
                If Not c2 Is Nothing Then c2(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12).ClearContents
            End If
        Next
    End If
    .Parent.Close True
End With
End Sub
PS : dans les feuilles les dates étaient des textes, je les ai converties en vraies dates (nombres).

A+
 

Pièces jointes

  • STAT(1).xlsm
    108.2 KB · Affichages: 6
  • Classeur1.xlsx
    12.3 KB · Affichages: 5
Vote positif 0 Vote négatif
M

michokette

XLDnaute Nouveau
job75 à dit:
Bonjour michokette,

Téléchargez les 2 fichiers joints dans le même dossier (le bureau).

Modifiez les données du fichier source Classeur1.xlsx (y compris l'année) et testez ces 2 macros :
VB: 
Sub MAJ_Mois()
'se lance par les touches Ctrl+M
If MsgBox("Etes-vous sûr qu'il faut mettre à jour les mois ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Dim source$, w As Worksheet, c As Range, c1 As Range
source = ThisWorkbook.Path & "\Classeur1.xlsx" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(source).Sheets(1)
    For Each w In ThisWorkbook.Worksheets
        Set c = .Cells.Find(Replace(w.Name, " ", "*") & "*", , xlValues, xlWhole)
        If Not c Is Nothing Then
            Set c1 = w.Cells.Find("Qté N")
            If Not c1 Is Nothing Then c1(1, 2).Resize(, 12) = c(2, 2).Resize(, 12).Value
            Set c1 = w.Cells.Find("C A N")
            If Not c1 Is Nothing Then c1(1, 2).Resize(, 12) = c(3, 2).Resize(, 12).Value
        End If
    Next
    .Parent.Close True
End With
End Sub

Sub Nouvelle_Annee()
If MsgBox("Etes-vous sûr qu'il faut créer une nouvelle année ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Dim source$, w As Worksheet, c As Range, c1 As Range, n%, c2 As Range
source = ThisWorkbook.Path & "\Classeur1.xlsx" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(source).Sheets(1)
    Set c = .Cells.Find("FamilleArticle", , xlValues, xlWhole)
    If Not c Is Nothing Then
        For Each w In ThisWorkbook.Worksheets
            Set c1 = w.Cells.Find("FamilleArticle")
            If Not c1 Is Nothing Then
                n = n + 1
                If n = 1 Then If Year(c(1, 3)) = Year(c1(1, 2)) Then MsgBox "Modifiez l'année du fichier source !", 48: Exit Sub
                w.Cells.Find("FamilleArticle", c1)(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12) = c(1, 3).Resize(, 12).Value
            End If
            Set c1 = w.Cells.Find("Qté N")
            If Not c1 Is Nothing Then
                Set c2 = w.Cells.Find("Qté N*-*")
                If Not c2 Is Nothing Then c2(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12).ClearContents
            End If
            Set c1 = w.Cells.Find("C A N")
            If Not c1 Is Nothing Then
                Set c2 = w.Cells.Find("C A N*-*")
                If Not c2 Is Nothing Then c2(1, 2).Resize(, 12) = c1(1, 2).Resize(, 12).Value
                c1(1, 2).Resize(, 12).ClearContents
            End If
        Next
    End If
    .Parent.Close True
End With
End Sub
PS : dans les feuilles les dates étaient des textes, je les ai converties en vraies dates (nombres).

A+
Cliquez pour agrandir...
Bonjour job75

testé ce matin, la proposition de votre macro.
Qu’une chose à dire : parfait
Merci une fois de plus de votre aide
Bonne journée à vous
Bien cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
124
marie3107
M
X
  • Question
XL 2019 Copier / Coller une ligne entre deux fichiers depuis un 3ème fichier
Réponses
0
Affichages
601
xorf
X
C
  • Résolu(e)
XL 2019 Ma fonction copier/coller en VBA ignore le filtre :/
Réponses
8
Affichages
611
casualexcel
C
S
  • Résolu(e)
Microsoft 365 VBA création ligne en fonction d'un nombre et occurrence copier coller
Réponses
6
Affichages
979
simsinaty
S
L
  • Question
XL 2019 Erreur 9 : Copier/Coller d'une feuille extérieur
Réponses
2
Affichages
371
Hasco
Hasco
A
  • Question
Microsoft 365 Copier/coller en boucle avec un nb variable de ligne
Réponses
4
Affichages
691
A-F
A
C
  • Question
Word VBA Excel-Word: Coller du texte l'un en dessous de l'autre
Réponses
1
Affichages
3 K
Conrad13
C
N
  • Question
XL 2013 RESOLU - MACRO Copier/Coller les cellules d'une ligne en fonction d'un critère
Réponses
9
Affichages
5 K
Kantarus
Kantarus
M
  • Question
XL 2013 vba copier-coller les lignes selon valeur d'une colonne indiquée dans inputbox
Réponses
11
Affichages
3 K
manup13
M
W
  • Question
Création d'une base par copier coller en macro vba avec une sélection multiple
Réponses
8
Affichages
2 K
Wmerlin
W

Membres actuellement en ligne

7 membres et 109 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 083
Messages
2 085 189
Membres
102 809
dernier inscrit
Sandrine83