Condition pour copier

T

Turbo

XLDnaute Junior
Alors voila, je refais appel a vos talents de VBAiste pour m'aider a résoudre un problème....

Explication de ma macro :

La macro çi dessous permet d'enregistrer des valeurs qui sont sur la feuille source ( qui est propre aux utilisateurs, et qui possède le bouton pour activer ma macro ) vers une autre feuilles excel.
Selon les initiales rentrées dans la feuille source, la macro permettra d'enregistrer les données de la feuille source, dans différentes colonnes de la feuille de destination.

Code: 
Private Sub Enregistrer_Click()
        
    Dim myRange As Range
    Workbooks("Formulaire heures modif 08.xls").Activate
    With Sheets("Mensuel")
    .Range("AK7:AK81").Copy
    If Val(Cells(3, 25).Value) = "MLB" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("B7:B81")
    ElseIf Val(Cells(3, 25).Value) = "IB" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("C7:C81")
    ElseIf Val(Cells(3, 25).Value) = "MHR" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("D7:D81")
    ElseIf Val(Cells(3, 25).Value) = "FF" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("E7:E81")
    ElseIf Val(Cells(3, 25).Value) = "Gry" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("F7:F81")
    ElseIf Val(Cells(3, 25).Value) = "CR" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("H7:H81")
    ElseIf Val(Cells(3, 25).Value) = "GB" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("I7:I81")
    ElseIf Val(Cells(3, 25).Value) = "OA" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("K7:K81")
    ElseIf Val(Cells(3, 25).Value) = "HD" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("L7:L81")
    ElseIf Val(Cells(3, 25).Value) = "PM" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("M7:M81")
    ElseIf Val(Cells(3, 25).Value) = "SG" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("N7:N81")
    ElseIf Val(Cells(3, 25).Value) = "KI" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("O7:O81")
    ElseIf Val(Cells(3, 25).Value) = "CM" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("P7:P81")
    ElseIf Val(Cells(3, 25).Value) = "AR" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("Q7:Q81")
    ElseIf Val(Cells(3, 25).Value) = "FE" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("R7:R81")
    ElseIf Val(Cells(3, 25).Value) = "PF" Then
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        With Sheets("DEC")
        Set myRange = Worksheets("DEC").Range("S7:S81")
    Else
        MsgBox ("Erreur dans le nom")
    End If
    End With
    myRange.Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    End With
            
End Sub

Je n'arrive pas a corriger le code pour qu'il fonctionne ( et qu'il fasse ce dont je demande accessoirement ) ...

Merci de prendre de votre temps a essayer de m'aider ;)

Je vous joins avec, les 2 fichiers excels :

Edit : Il faut que les deux fichiers excel soient ouvert !!
 

Pièces jointes

  • Formulaire heures modif 08.zip
    17.4 KB · Affichages: 16
  • Formulaire heures modif 08.zip
    17.4 KB · Affichages: 17
  • Formulaire heures modif 08.zip
    17.4 KB · Affichages: 17
  • Synthése Aôut, Sept Modif2 07BIS.zip
    28.1 KB · Affichages: 15
  • Synthése Aôut, Sept Modif2 07BIS.zip
    28.1 KB · Affichages: 14
  • Synthése Aôut, Sept Modif2 07BIS.zip
    28.1 KB · Affichages: 16
Dernière édition:
Trier par date Trier par votes
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : Condition pour copier

Bonjour Turbo, bonjour le forum,

Elle est sur quel Classeur / Onglet la cellule Cells(3, 25) ?
Peut-être manque-t-il juste un point devant : If Val(.Cells(3, 25).Value) si c'est une cellule de l'onglet Mensuel du classeur Formulaire heures modif 08.xls.
 
Vote positif 0 Vote négatif
Celeborn61

Celeborn61

XLDnaute Occasionnel
Re : Condition pour copier

Salut,

Elle n'a pas finit de planter ta macro.

Tu ouvres des "With" sans jamais les refermer.
Pour information, les "With" sont là pour faciliter la lecture de nous, pauvres humains.

With Selection
.value=15
End With

Reviens à écrire
Selection.value=15

Mais permet en cas d'action multiple de ne pas réécrire "Selection"

Les "With" peuvent être imbriqués mais doivent être refermé avant toutes instructions de structure non imbriquées.
 
Dernière édition:
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : Condition pour copier

Bonjour Turbo, bonjour le forum,

Essaie comme ça :
Code: 
Private Sub Enregistrer_Click()
 
Dim myRange As Range
Dim s As Worksheet 'déclare la variable s
Set s = Sheets("DEC") 'définit la variasble s
Workbooks("Formulaire heures modif 08.xls").Activate
Sheets("Mensuel").Range("AK7:AK81").Copy
 
Select Case Val(Sheets("Mensuel").Cells(3, 25).Value)
 
    Case "MLB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("B7:B81")
    Case "IB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("C7:C81")
    Case "MHR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("D7:D81")
    Case "FF"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("E7:E81")
    Case "Gry"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("F7:F81")
    Case "CR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("H7:H81")
    Case "GB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("I7:I81")
    Case "OA"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("K7:K81")
    Case "HD"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("L7:L81")
    Case "PM"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("M7:M81")
    Case "SG"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("N7:N81")
    Case "KI"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("O7:O81")
    Case "CM"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("P7:P81")
    Case "AR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("Q7:Q81")
    Case "FE"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("R7:R81")
    Case "PF"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("S7:S81")
    Case Else
        MsgBox ("Erreur dans le nom")
End Select
 
myRange.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
 
End Sub
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : Condition pour copier

Bonjour Turbo, bonjour le forum,

J'ai pris le temps de tester en ouvrant les fichiers et j'ai modifié pour que ça fonctionne. Ça donne :

Code: 
Private Sub Enregistrer_Click()
 
Dim myRange As Range
Dim s As Worksheet 'déclare la variable s
Set s = Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Sheets("DEC")  'définit la variasble s
Workbooks("Formulaire heures modif 08.xls").Activate
Sheets("Mensuel").Range("AK7:AK81").Copy
 
Select Case Sheets("Mensuel").Cells(3, 25).Value
 
    Case "MLB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("B7:B81")
    Case "IB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("C7:C81")
    Case "MHR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("D7:D81")
    Case "FF"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("E7:E81")
    Case "Gry"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("F7:F81")
    Case "CR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("H7:H81")
    Case "GB"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("I7:I81")
    Case "OA"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("K7:K81")
    Case "HD"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("L7:L81")
    Case "PM"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("M7:M81")
    Case "SG"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("N7:N81")
    Case "KI"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("O7:O81")
    Case "CM"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("P7:P81")
    Case "AR"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("Q7:Q81")
    Case "FE"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("R7:R81")
    Case "PF"
        Workbooks("Synthése Aôut, Sept Modif2 07BIS.xls").Activate
        Set myRange = s.Range("S7:S81")
    Case Else
        MsgBox ("Erreur dans le nom")
End Select
 
myRange.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
 
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
82
Latias
L
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
364
M@xu3L
M
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
470
Phil69970
Phil69970
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
360
crocrocro
C
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
186
Francky79
F
S
  • Question
XL 2021 macro VBA excel
Réponses
1
Affichages
168
crocrocro
C
J
  • Question
Microsoft 365 Erreur de compilation: sub, fonction ou property attendue
Réponses
4
Affichages
140
dysorthographie
dysorthographie
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
932
thivame
T
G
  • Question
Microsoft 365 Réduire la taille de la macro ?
Réponses
9
Affichages
606
Staple1600
Staple1600
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
235
florian50470
F

Membres actuellement en ligne

8 membres et 133 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 248
Messages
2 086 596
Membres
103 252
dernier inscrit
Ersar