XL 2013 macro

sev31130

sev31130

XLDnaute Impliqué
Bonjour,
je ne suis pas spécialiste des macros (ni de rien d'ailleurs)
Voila mon problème j'ai une macro sur un fichier qui se nomme
F_pressemensuel FANFAN.xlsm (1) qui copie des lignes sur un fichier de même structure qui se nomme F_presse_jour_complet_2017.xlsm (2)
Je voudrais pouvoir adapter cette macro pour que cette copie soit étendue à un second fichier qui se nomme presse-jour-complet-2016.xlsm (3)
Alors je ne sais pas si vous pouvez faire copie de (1) sur (2) et (3) en même temps
sinon je la mettrais en place sur (2) pour copie sur (3)
Voici la macro ci-dessous
Par avance merci

Sub mamacro()
Dim W As Workbook, datefich2 As Date, ligfich2 As Integer
Dim Presence As Boolean, feuille As Byte, mafeuille As String
Dim derlig As Integer, ligfeuil As Integer, col As Byte
Dim nomfich As String, chemin As String, fichier2 As String, monfich As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nomfich = ActiveWorkbook.Name 'nom du fichier a partir duquel tu lances ta macro
chemin = Workbooks(ActiveWorkbook.Name).Path
fichier2 = "F_presse_jour_complet_2017.xlsm"
UserForm1.Show vbModeless 'message
Presence = False 'pour la recherche du fichier mensuel
For Each W In Workbooks
If W.Name = fichier2 Then
Presence = True
Exit For
End If
Next W
If Presence = False Then 'si fichier pas ouvert ouverture du fichier à modifier pour faire l'inverse
UserForm1.Caption = "chargement du fichier"
monfich = chemin & "\" & fichier2
Workbooks.Open (monfich)
End If
derlig = Workbooks(nomfich).Sheets("01").Range("D7").End(xlDown).Row 'derniere ligne du fichier mensuel
ligfeuil = Workbooks(fichier2).Sheets("01").Range("l7").End(xlDown).Row + 1 'derniere ligne du fichier journalier
datefich2 = Workbooks(fichier2).Sheets("01").Range("c" & ligfeuil).Value
ligfich2 = derlig
While Workbooks(nomfich).Sheets("01").Cells(ligfich2, 3).Value <> datefich2
ligfich2 = ligfich2 - 1
Wend
For feuille = 1 To 25 'boucle dur les 25 feuilles
mafeuille = Format(feuille, "00")
UserForm1.Caption = "Mise à jour feuille " & mafeuille
Windows(nomfich).Activate
Sheets(mafeuille).Select
Range(Cells(ligfich2, 4), Cells(derlig, 16)).Copy 'Select
Windows(fichier2).Activate
Sheets(mafeuille).Select
Range("D" & ligfeuil).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
UserForm1.Hide
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
Trier par date Trier par votes
Calvus

Calvus

XLDnaute Barbatruc
Bonjour sev31130, le forum,

A la lecture de ton code, il me semble qu'il te suffit de faire :
VB: 
chemin2 = Workbooks(ActiveWorkbook.Name).Path
fichier3 = "presse-jour-complet-2016.xlsm"
au début de ta procédure,
et à la fin :
VB: 
Windows(fichier3).Activate
Sheets(mafeuille).Select
Range("D" & ligfeuil).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next

A adapter dans tes lignes.

Dis nous
 
Vote positif 0 Vote négatif
sev31130

sev31130

XLDnaute Impliqué
merci ce que tu me dis au debut je le rajoute ou ?
à la fin je rajoute ou je remplace
et si je le rajoute je le mets juste avant le end sub ?
est ce que la cela irait :
Sub mamacro()
Dim W As Workbook, datefich2 As Date, ligfich2 As Integer
Dim Presence As Boolean, feuille As Byte, mafeuille As String
Dim derlig As Integer, ligfeuil As Integer, col As Byte
Dim nomfich As String, chemin As String, fichier2 As String, monfich As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nomfich = ActiveWorkbook.Name 'nom du fichier a partir duquel tu lances ta macro
chemin = Workbooks(ActiveWorkbook.Name).Path
chemin2 = Workbooks(ActiveWorkbook.Name).Path
fichier2 = "F_presse_jour_complet_2017.xlsm"
fichier3 = "presse-jour-complet-2016.xlsm"
UserForm1.Show vbModeless 'message
Presence = False 'pour la recherche du fichier mensuel
For Each W In Workbooks
If W.Name = fichier2 Then
Presence = True
Exit For
End If
Next W
If Presence = False Then 'si fichier pas ouvert ouverture du fichier à modifier pour faire l'inverse
UserForm1.Caption = "chargement du fichier"
monfich = chemin & "\" & fichier2
Workbooks.Open (monfich)
End If
derlig = Workbooks(nomfich).Sheets("01").Range("D7").End(xlDown).Row 'derniere ligne du fichier mensuel
ligfeuil = Workbooks(fichier2).Sheets("01").Range("l7").End(xlDown).Row + 1 'derniere ligne du fichier journalier
datefich2 = Workbooks(fichier2).Sheets("01").Range("c" & ligfeuil).Value
ligfich2 = derlig
While Workbooks(nomfich).Sheets("01").Cells(ligfich2, 3).Value <> datefich2
ligfich2 = ligfich2 - 1
Wend
For feuille = 1 To 25 'boucle dur les 25 feuilles
mafeuille = Format(feuille, "00")
UserForm1.Caption = "Mise à jour feuille " & mafeuille
Windows(nomfich).Activate
Sheets(mafeuille).Select
Range(Cells(ligfich2, 4), Cells(derlig, 16)).Copy 'Select
Windows(fichier2).Activate
Sheets(mafeuille).Select
Range("D" & ligfeuil).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(fichier3).Activate
Sheets(mafeuille).Select
Range("D" & ligfeuil).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
UserForm1.Hide
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
Vote positif 0 Vote négatif
Calvus

Calvus

XLDnaute Barbatruc
Re,

Essaye comme ceci, mais sans fichier, pas évident, en tout cas pour moi...
VB: 
Option Explicit

Sub mamacro()
Dim W As Workbook, datefich2 As Date, ligfich2 As Integer
Dim Presence As Boolean, feuille As Byte, mafeuille As String
Dim derlig As Integer, ligfeuil As Integer, col As Byte
Dim nomfich As String, chemin As String, fichier2 As String, monfich As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nomfich = ActiveWorkbook.Name 'nom du fichier a partir duquel tu lances ta macro
chemin = Workbooks(ActiveWorkbook.Name).Path
'chemin2 = Workbooks(ActiveWorkbook.Name).Path
fichier2 = "F_presse_jour_complet_2017.xlsm"
fichier3 = "presse-jour-complet-2016.xlsm"
UserForm1.Show vbModeless 'message
Presence = False 'pour la recherche du fichier mensuel
    For Each W In Workbooks
        If W.Name = fichier2 Or W.Name = fichier3 Then 'Correction
        Presence = True
        Exit For
        End If
    Next W
        If Presence = False Then 'si fichier pas ouvert ouverture du fichier à modifier pour faire l'inverse
            UserForm1.Caption = "chargement du fichier"
            monfich = chemin & "\" & fichier2
            Workbooks.Open (monfich)
            monfich = chemin & "\" & fichier3 'Correction
            Workbooks.Open (monfich) 'Correction
        End If
derlig = Workbooks(nomfich).Sheets("01").Range("D7").End(xlDown).Row 'derniere ligne du fichier mensuel
ligfeuil = Workbooks(fichier2).Sheets("01").Range("l7").End(xlDown).Row + 1 'derniere ligne du fichier journalier
ligfeui3 = Workbooks(fichier3).Sheets("01").Range("l7").End(xlDown).Row + 1 'Correction
datefich2 = Workbooks(fichier2).Sheets("01").Range("c" & ligfeuil).Value
datefich3 = Workbooks(fichier3).Sheets("01").Range("c" & ligfeuil).Value 'Correction
ligfich2 = derlig
While Workbooks(nomfich).Sheets("01").Cells(ligfich2, 3).Value <> datefich2
    ligfich2 = ligfich2 - 1
Wend
    For feuille = 1 To 25 'boucle dur les 25 feuilles
        mafeuille = Format(feuille, "00")
        UserForm1.Caption = "Mise à jour feuille " & mafeuille
        Windows(nomfich).Activate
        Sheets(mafeuille).Select
        Range(Cells(ligfich2, 4), Cells(derlig, 16)).Copy 'Select
        Windows(fichier2).Activate
        Sheets(mafeuille).Select
        Range("D" & ligfeuil).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next
    For feuille = 1 To 25 'boucle dur les 25 feuilles
        mafeuille = Format(feuille, "00")
        Windows(fichier3).Activate
        Sheets(mafeuille).Select
        Range("D" & ligfeui3).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next
UserForm1.Hide
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
A+
 
Vote positif 0 Vote négatif
sev31130

sev31130

XLDnaute Impliqué
voila tu as les fichiers
j'ai mis la macro que tu m'as envoyé et tu verras ca ne fonctionne pas
merci par avance
alors même si je dois faire copie du 2 sur 3 c'est pas grave
Par avance merci
 

Pièces jointes

  • F_pressemensuel FANFAN.xlsm
    585.3 KB · Affichages: 31
  • F_presse_jour_complet_2017.xlsm
    6.5 MB · Affichages: 25
Vote positif 0 Vote négatif
Calvus

Calvus

XLDnaute Barbatruc
Re,

Alors, plusieurs remarques.
1/ c'est le dernier code que je t'avais envoyé qu'il fallait mettre dans la macro.
Et celui-ci fonctionnait, si ce n'est que....
2/ Tes fichiers ne sont pas identiques, on ne pouvait donc copier au bon endroit...

Ce code fonctionne :
A remplacer dans ton module :
VB: 
Option Explicit


Sub mamacro()
Dim W As Workbook, datefich2 As Date, datefich3 As Date, ligfich2 As Integer
Dim Presence As Boolean, feuille As Byte, mafeuille As String
Dim derlig As Integer, ligfeuil As Integer, ligfeuil3 As Integer, col As Byte
Dim nomfich As String, chemin As String, fichier2 As String, fichier3 As String, monfich As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nomfich = ActiveWorkbook.Name 'nom du fichier a partir duquel tu lances ta macro
chemin = Workbooks(ActiveWorkbook.Name).Path
'chemin2 = Workbooks(ActiveWorkbook.Name).Path
fichier2 = "F_presse_jour_complet_2017.xlsm"
fichier3 = "presse-jour-complet-2016.xlsm"
UserForm1.Show vbModeless 'message
Presence = False 'pour la recherche du fichier mensuel
    For Each W In Workbooks
        If W.Name = fichier2 Or W.Name = fichier3 Then 'Correction
        Presence = True
        Exit For
        End If
    Next W
        If Presence = False Then 'si fichier pas ouvert ouverture du fichier à modifier pour faire l'inverse
            UserForm1.Caption = "chargement du fichier"
            monfich = chemin & "\" & fichier2
            Workbooks.Open (monfich)
            monfich = chemin & "\" & fichier3 'Correction
            Workbooks.Open (monfich) 'Correction
        End If
derlig = Workbooks(nomfich).Sheets("01").Range("D7").End(xlDown).Row 'derniere ligne du fichier mensuel
ligfeuil = Workbooks(fichier2).Sheets("01").Range("l7").End(xlDown).Row + 1 'derniere ligne du fichier journalier
ligfeuil3 = Workbooks(fichier3).Sheets("01").Range("D7").End(xlDown).Row + 1 'Correction
datefich2 = Workbooks(fichier2).Sheets("01").Range("c" & ligfeuil).Value
datefich3 = Workbooks(fichier3).Sheets("01").Range("c" & ligfeuil3).Value 'Correction
ligfich2 = derlig
While Workbooks(nomfich).Sheets("01").Cells(ligfich2, 3).Value <> datefich2
    ligfich2 = ligfich2 - 1
Wend
    For feuille = 1 To 25 'boucle dur les 25 feuilles
        mafeuille = Format(feuille, "00")
        UserForm1.Caption = "Mise à jour feuille " & mafeuille
        Windows(nomfich).Activate
        Sheets(mafeuille).Select
        Range(Cells(ligfich2, 4), Cells(derlig, 16)).Copy 'Select
        Windows(fichier2).Activate
        Sheets(mafeuille).Select
        Range("D" & ligfeuil).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next
    For feuille = 1 To 25 'boucle dur les 25 feuilles
        mafeuille = Format(feuille, "00")
        Windows(fichier3).Activate
        Sheets(mafeuille).Select
        Range("D" & ligfeuil3).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next
UserForm1.Hide
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Bonne journée
 
Vote positif 0 Vote négatif
sev31130

sev31130

XLDnaute Impliqué
bonsoir

le but du jeu c'est de copier les lignes

D7:p37 du fichier 1 sur les fichiers 2 et 3 en testant la dernière date sur ces fichiers par rapport au 1 et copier
donc 01 en 01, 02 en 02 etc...
Alors tu me dis il y a des lignes vides oui mais question
si sur le fichier 3 la plage Dx;Ky il y a des lignes
je pensais qu'il me copiait la la plage Lx:py
merci
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question
XL 2021 Sauvegarde onglet
Réponses
10
Affichages
221
nano33320
N
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
95
marie3107
M
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
180
aziz
A
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
137
marie3107
M
H
  • Résolu(e)
XL 2019 récupérer une donnée d'un fichier csv pour le copier vers un autre
2
Réponses
27
Affichages
1 K
Hutchy33
H
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
175
Francky79
F
Usine à gaz
  • Question
XL 2021 Accélérer la copie du classeur actif faite par vba
2 3 4
Réponses
45
Affichages
2 K
Usine à gaz
Usine à gaz
A
  • Question
XL 2016 Boucle sur sous répertoire fso.GetFolder SharePoint
Réponses
0
Affichages
267
Aldonanou
A
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
519
mouchtre
mouchtre
R3n0W
  • Résolu(e)
XL 2016 If Not xRgSel Is Nothing Then --> Ne marche pas
Réponses
10
Affichages
157
R3n0W
R3n0W

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 47 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 165
Messages
2 085 880
Membres
103 009
dernier inscrit
dede972