XL 2010 copier coller une feuille dans le même classeur

[bodiallo]

je me suis inspire de plusieurs bouts de code pour me batir ce code.
Il vérifie si la feuillet à dupliquer existe, si vrai duplique la feuille dans le même classeur. j'insère dans la cellule C3 la date du mois précédent et jusque là il n'y a pas de problème. vue que le nombre de jour de chaque mois varie, je parcours la ligne de ma nouvelle feuille en vérifiant si le mois de cellule C3 et identique aux autres cellules sinon supprime la colonne contenant le mois différent du mois de C3. c'est là que commence mes difficultés, il me supprime ces colonnes sur la feuille original. et depuis je ne parviens pas à corriger cela. je joins mon classeur pour plus de compréhension.
je demande votre apport pour rectifier mon ou mes erreurs.
voici mon code

Public Function FeuilleExiste(FeuilleAVerifier As String) As Boolean
'fonction qui vérifie si la "FeuilleActive" existe dans le Classeur actif
On Error GoTo SiErreur
Dim Feuille As Worksheet
Dim SheetName As String
    SheetName = ActiveWorkbook.ActiveSheet.Name
    FeuilleExiste = False
    For Each Feuille In Worksheets
        If Feuille.Name = SheetName Then
            FeuilleExiste = True
            Exit Function
        End If
    Next Feuille
Exit Function
SiErreur:
MsgBox "Une erreur s'est produite..."
FeuilleExiste = CVErr(xlErrNA)
End Function
Sub Test()
'Utilisation de la fonction "FeuilleExiste" puis ajout d'une nouvelle feuille
Dim SheetName As String
Dim i As Integer
    SheetName = ActiveWorkbook.ActiveSheet.Name
    If FeuilleExiste(SheetName) = True Then
        'MsgBox "La Feuille " & SheetName & " existe !"
'ajoute uen Feuille tout à la fin du Classeur en comptant les Feuilles avec la méthode Worksheets.Count et la nommée
        'Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Format(Date - 2, "mmmm") & "-" & Format(Date, "yy") & "_KPI "
        Sheets(SheetName).Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(Date + 14, "mmmm") & "-" & Format(Date, "yy") & "_KPI "
        'entre la date du 1er jour du mois en cours dans la cellule C3
        ActiveSheet.Range("C3") = DateSerial(Year(Date), Month(Date) + 1, 1)
        'recuperation du numéro de colonne de la cellule contenant la date du dernier jour du mois en cours     numérodecolonnedelacelluleactive  ActiveCell.column
        'DerniereColonneUtilisee = Cells(3, Columns.Count).End(xlToLeft).Column 'où 3 est le numéro de la ligne
        For Each cell In ActiveSheet.Range("C3:AG3")
            If Month(cell.Value) <> Month(ActiveSheet.Range("C3")) Then
                   i = cell.Column
                   Columns(Val(i)).Delete Shift:=xlToLeft
            End If
        Next
    Else
        MsgBox "La Feuille 'Test_1' n'existe pas!"
    End If
End Sub

 

[job75]

Bonjour bodiallo, bienvenue sur XLD,

Concernant la fonction FeuilleExiste la feuille active se trouve forcément dans le classeur actif... Ecrivez plutôt :

Function FeuilleExiste(FeuilleAVerifier As String) As Boolean
On Error Resume Next
FeuilleExiste = Not IsError(Sheets(FeuilleAVerifier))
End Function

Sans fichier joint pour tester je ne vous aiderai pas plus.

A+

 

[bodiallo]

merci pour votre apport
j'ai modifier ma fonction avec celle envoyé.je joins le fichier

 

[job75]

Bonjour bodiallo, le forum,

Votre fichier n'a vraiment ni queue ni tête, voyez celui-ci et la macro :

Sub NouveauMois()
Dim dat As Date, nom$, col%
If Not IsDate([C3]) Then Exit Sub
dat = DateSerial(Year([C3]), Month([C3]) + 1, 1)
nom = Application.Proper(Format(dat, "mmmm-yyyy")) & "_KPI"
If FeuilleExiste(nom) Then MsgBox "'" & nom & "' est déjà créée...": Exit Sub
ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = nom
[C3] = dat
For col = 31 To 33
    Columns(col).Hidden = Month(Cells(3, col)) <> Month(dat)
Next
End Sub

A+

 

[bodiallo]

MERCI BIEN
vous avez abrogé mes peines sur ce travail.

une étape franchie

 

[bodiallo]

j'essai maintenant de comprendre votre code
pouvez vous explique ces deux lignes. cela évitera probablement des questions au futur
Dim dat As Date, nom$, col%
Application.Proper

 

[job75]

La première ligne déclare les variables nom As String et col As Integer.

Application.Proper c'est la fonction Excel NOMPROPRE.

 

[bodiallo]

bonjour
je reviens encore avec du code, il copie la valeur des cellules se trouvant dans 4 classeurs sources et le colle dans ma feuille destination. je le poste pour que les uns et autres y apport probablement une amélioration; afin qu'il soit profitable à d'autres débutants
il y a aussi une notification de mise à jour qui s'affiche dont je ne parviens pas à désactiver. cette notification vient d'un de mes classeurs sources.

Private Sub Workbook_Open()
    Dim i, nbreNul, ligne, colonne, lastline, lastline1, lastline2, lastline3 As Integer
    Dim Fichier, Fichier1, Fichier2, Fichier3, nomfeuil, nomClasseur, ClasseurACQuery, ClasseurDonneesUsine, ClasseurCentral As String
    Dim base, mabase, mabase1, mabase2, mabase3 As Worksheet
    Dim celluleDepart, nonVide As Variant
    Dim rg, rang As Range
    Dim nbreNulDeci As Single
   
    Application.ScreenUpdating = False
   
        'fichier destination
        nomfeuil = ActiveWorkbook.ActiveSheet.Name
        Worksheets(nomfeuil).Activate
       
        'initialisation de la variable
        Set base = Sheets(nomfeuil)
       
        'recupere la ligne et la colonne du jour precedent
        For Each rg In base.Range("C3:AG3")
            If rg = Date - 1 Then
                ligne = rg.Row
                colonne = rg.Column
            End If
         Next rg
          
     'chemin d'acces au 2ème fichier source
     
      Fichier1 = "X\AC_QUERY.xlsx"
    
      If Dir(Fichier1) = "" Then
        MsgBox "Fichier " & Fichier1 & " introuvable"
        Exit Sub
      End If     
      With Workbooks.Open(Fichier1)
        ' Récupération du nom du classeur + extension
        For i = Len(Fichier1) To 1 Step -1
            If Mid(Fichier1, i, 1) = "\" Then Exit For
        Next
        ClasseurACQuery = Mid(Fichier1, i + 1, Len(Fichier1))

        'initialisation et recuperation du numéro de la ligne du jour
        Set mabase1 = Workbooks(ClasseurACQuery).Sheets("DATA")
       
        For Each rang In mabase1.Range("B1:B1000")
            If rang = Date - 1 Then
                lastline1 = rang.Row
            End If
         Next rang
     
        'copie la valeur des cellules et colle
        .Sheets("DATA").Range("C" & lastline1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 3, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False     
       
        .Sheets("DATA").Range("E" & lastline1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 4, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        nbreNul = 0
        .Sheets("DATA").Range("D" & lastline1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 5, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        nonVide = ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 5, colonne).Value
        If IsEmpty(nonVide) = True Then
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 5, colonne) = nbreNul
        End If
        .Close savechanges:=False

      End With

     'chemin d'acces au 3ème fichier source
     
      Fichier2 = "F:\Données usine.xlsx"
    
      If Dir(Fichier2) = "" Then
        MsgBox "Fichier " & Fichier2 & " introuvable"
        Exit Sub
      End If
     
      With Workbooks.Open(Fichier2)    

        ' Récupération du nom du classeur + extension
        For i = Len(Fichier2) To 1 Step -1
            If Mid(Fichier2, i, 1) = "\" Then Exit For
        Next
       
        ClasseurDonneesUsine = Mid(Fichier2, i + 1, Len(Fichier2))

        'initialisation et recuperation du numéro de la ligne du jour
        Set mabase2 = Workbooks(ClasseurDonneesUsine).Sheets("données amélioration continue")
       
        For Each rang In mabase2.Range("A5:A1000")
            If rang = Date - 1 Then
                lastline2 = rang.Row
            End If
         Next rang
     
        'copie la valeur des cellules AV et BA puis colle dans mon classeur actif
        .Sheets("données amélioration continue").Range("C" & lastline2).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 6, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
               
        .Sheets("données amélioration continue").Range("E" & lastline2).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 7, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
               
        .Sheets("données amélioration continue").Range("F" & lastline2).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 8, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        .Sheets("données amélioration continue").Range("G" & lastline2).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 9, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        nbreNulDeci = 0.0001
        .Sheets("données amélioration continue").Range("H" & lastline2).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 10, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           
            If ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 10, colonne).Value = 0 Then
            ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 10, colonne) = nbreNulDeci
            End If
        'cellule depart 
        celluleDepart = ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 12, colonne - 1).Value
        If IsEmpty(celluleDepart) = True Then
       
        .Sheets("données amélioration continue").Range("I" & lastline2 - 1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 12, colonne - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False           
           
        .Sheets("données amélioration continue").Range("J" & lastline2 - 1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 13, colonne - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        .Sheets("données amélioration continue").Range("K" & lastline2 - 1).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 14, colonne - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
        .Close savechanges:=False

      End With
     'chemin d'acces au 4ème fichier source
      'W:\Rapport consommations centrale janvier 2019.xlsx
      Fichier3 = "G:\Rapport consommations centrale janvier 2019.xlsx"
    
      If Dir(Fichier3) = "" Then
        MsgBox "Fichier " & Fichier3 & " introuvable"
        Exit Sub
      End If
     
      With Workbooks.Open(Fichier3)

        ' Récupération du nom du classeur + extension
        For i = Len(Fichier3) To 1 Step -1
            If Mid(Fichier3, i, 1) = "\" Then Exit For
        Next
       
        ClasseurCentral = Mid(Fichier3, i + 1, Len(Fichier3))

        'initialisation et recuperation du numéro de la ligne du jour
        Set mabase3 = Workbooks(ClasseurCentral).Sheets("Rapport")
       
        For Each rang In mabase3.Range("A5:A36")
            If rang = Date - 1 Then
                lastline3 = rang.Row
            End If
         Next rang
     
        'copie la valeur des cellules AV et BA  xlPasteSpecialOperationAdd
        .Sheets("Rapport").Range("DS" & lastline3).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 17, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
       
        .Sheets("Rapport").Range("G" & lastline3).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 18, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Sheets("Rapport").Range("O" & lastline3).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 18, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationAdd, SkipBlanks:=False, Transpose:=False
       
        .Close savechanges:=False

      End With
      'chemin d'acces au 1er fichier source
     
      Fichier = "D:\SAD20190114.xlsx"
    
      If Dir(Fichier) = "" Then
        MsgBox "Fichier " & Fichier & " introuvable"
        'Exit Sub
      End If
     
      With Workbooks.Open(Fichier)

        ' Récupération du nom du classeur + extension
        For i = Len(Fichier) To 1 Step -1
            If Mid(Fichier, i, 1) = "\" Then Exit For
        Next
       
        nomClasseur = Mid(Fichier, i + 1, Len(Fichier))

        'initialisation et recuperation du numéro de la ligne du jour
        Set mabase = Workbooks(nomClasseur).Sheets("Data Graph")
       
        For Each rang In mabase.Range("B1:B1000")
            If rang = Date - 1 Then
                lastline = rang.Row
            End If
         Next rang
     
        'copie la valeur des cellules AV et BA
        .Sheets("Data Graph").Range("AV" & lastline).Copy
       
        'colle les valeurs dans les cellules A1 et A2
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 1, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
       
        .Sheets("Data Graph").Range("BA" & lastline).Copy
        ThisWorkbook.Sheets(nomfeuil).Cells(ligne + 2, colonne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        .Close savechanges:=False

      End With   
               
End Sub

j'ai mis ce code dans le Workbook_Open() car je veux que le classeur source s'actualise dès son ouverture. Merci d'avance pour vos éventuels apports

 

[job75]

Bonjour bodiallo,

je reviens encore avec du code

Demandez à celui qui vous l'a fourni d'intervenir, d'autant que vous ne fournissez pas les fichiers.

A+

 

[bodiallo]

j'ai travaillé sur la taille de mes fichiers afin de pouvoir les joindres.