répéter une Macro

Version imprimable

Voir 40 message(s) de cette discussion en une page

répéter une Macro

Bonjour à tous,

comme vous l'avez peut etre lu dans ma présentation je débute en VBA. Et comme de bien entendu, comme tout débutant je souhaite mettre la charue avant les boeufs...

Bref, j'ai réussis a faire ce que je voulais avec ma macro d'une façon plus ou moins orthodoxe. Toutefois, j'aimerais que cette macros s'applique sur plusieurs cellules non contigues.

Voici la macro:
Définition: elle copie dans un autre classeurs les cellules spécifié d'une ligne si une des cellules de cette ligne n'est pas renseignée.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 Sub COPIEDONNEES() Dim NomFichierEntree Dim Sortie As Workbook Dim Entree As Workbook Dim FeuilleOrigine As Worksheet Dim FeuilleDestination As Worksheet Set Sortie = ThisWorkbook If IsEmpty(Range("D1")) Then ' On ouvre le classeur Set Entree = Workbooks.Open("C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx") 'Référence feuille origine des données à copier Set FeuilleOrigine = Entree.Sheets("Feuil1") 'Référence la feuille de destination des cellules copiées Set FeuilleDestination = Sortie.Sheets("Feuil1") 'on insert un ligne Rows("2").Insert Shift:=xlDown ' On copie les cellules vers la feuille de sortie depuis la feuille désirée FeuilleOrigine.Range("A2").Value = FeuilleDestination.Range("A4").Value FeuilleOrigine.Range("B2").Value = FeuilleDestination.Range("B4").Value FeuilleOrigine.Range("C2").Value = FeuilleDestination.Range("C4").Value ' On ferme le classeur Workbooks("Appro matiere.xlsx").Save Entree.Close End If End Sub
Je souhaiterai appliquer ce code aux cellules D3; D5; etc...

Je n'arrive pas a trouver quoi que ce soit la dessus ou ne comprends pas ce que je trouve.

Si possible je cherche un peu plus qu'une réponse, une explication :)

Merci pour le temps que vous me consacrerez

Cordialement

Bonjour,
Je ne sais pas si c'est une réponse à ta question mais voici une procédure avec 2 cas traitant de cellules non contigües.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub SelectionNonContigue()
 Dim wkb As Workbook, sht As Worksheet, rng As Range
 Dim cel As Range, celCopy As Range
 Dim count As Byte: count = 2
 Set wkb = ThisWorkbook: Set sht = wkb.Worksheets("Test")
 Set rng = sht.Range("A2:C3,A5:C5,A8:C8")
 ' Cas N°1 - Copie des cellules non contigües vers la cellule G2 de la même feuille
 rng.Copy sht.Range("G2")
 ' Cas N°2 - Parcoure toutes les éléments de la plage de cellules non contigües
 '           Test si la valeur des cellules de la colonne 2 de la plage est supérieure à 3
 '           Dans l'affirmative copie vers la colonne K de la même feuille
 For Each cel In rng
  If cel.Column = 2 And cel > 3 Then ' Test si la valeur de la colonne 2 est > 3
   Set celCopy = sht.Range(cel.Offset(0, -1), cel.Offset(0, 1))
   celCopy.Copy sht.Range("K" & count): count = count + 1
  End If
 Next
End Sub

Edit: Oubli

Un exemple légèrement commenté à adapter à ton contexte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx"
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                       'verifier que le fichier existe bel et bien
 
    Set Entree = Workbooks.Open(Fichier)         'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 1 To 19 Step 2                   'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("D" & i)
        Next i
    End With
    Entree.Close True                            'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    Set Entree = Nothing                         'on libère la variable Entree
End If
End Sub
 
'Sous procédure paramétrée qui permet de copier les 3 données vers Feuil1 du classeur Wbk
'Si c=D1 on insère une ligne à la place de ligne 2 et on y copies les cellules A2:B2 et C2 respectivement
'l'offset désigne 1 lignes en bas
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal Cellule As Range)
 
If IsEmpty(Cellule) Then
    With Wbk.Worksheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("A2:C2").Value = Cellule.Offset(1, 0).Resize(1, 3).Value
    End With
End If
End Sub

12/10/2012, 13h05
JiBé91
Merci pour vos réponses.

alors, ai je bien compris la fonction suivante:
Code:

1 2 For i = 1 To 19 Step 2 COPIEDONNEES Entree, .Range("D" & i)
Pour une cellule sur deux de la colonne D entre les lignes 1 et 19 c'est bien ça?

Mercatog, comment dois je intégrer ce que tu m'as écris? Dois je le metre dans un autre module?
12/10/2012, 13h35
mercatog

Fais le tout dans un module et appelle la procédure Main

je bloque... :oops:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx"
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                       'verifier que le fichier existe bel et bien
 
    Set Entree = Workbooks.Open(Fichier)         'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 1 To 19 Step 2                   'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("D" & i)
        Next i
    End With
    Entree.Close True                            'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    Set Entree = Nothing                         'on libère la variable Entree
End If
End Sub
 
Sub COPIEDONNEES()
Dim NomFichierEntree
Dim Sortie As Workbook
Dim Entree As Workbook
Dim FeuilleOrigine As Worksheet
Dim FeuilleDestination As Worksheet
 
    Set Sortie = ThisWorkbook
 
    If IsEmpty(Range("Di")) Then
 
        ' On ouvre le classeur
        Set Entree = Workbooks.Open("C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx")
 
        'Référence feuille origine des données à copier
        Set FeuilleOrigine = Entree.Sheets("Feuil1")
 
        'Référence la feuille de destination des cellules copiées
        Set FeuilleDestination = Sortie.Sheets("Feuil1")
 
        'on insert un ligne
 
        Rows("2").Insert Shift:=xlDown
 
        ' On copie les cellules vers la feuille de sortie depuis la feuille désirée
        FeuilleOrigine.Range("A2").Value = FeuilleDestination.Range("A4").Value
        FeuilleOrigine.Range("B2").Value = FeuilleDestination.Range("B4").Value
        FeuilleOrigine.Range("C2").Value = FeuilleDestination.Range("C4").Value
 
        ' On ferme le classeur
        Workbooks("Appro matiere.xlsx").Save
        Entree.Close
 
    End If
 
End Sub

Voila ce que j'écris et ça bloque à la ligne 12 sur "COPIEDONNES" "Erreur de compilation, nombre d'arguments incorrect ou affectation de propriété incorrect"

12/10/2012, 14h34
mercatog

Je t'arrête ici sans plus!
reprenons l'explication

Si D1 est vide on insère une ligne vide à la place de la ligne 2 et on copie les données de A4, B4 et C4

Ensuite

Si D3 est est vide on insère une ligne vide à la place de la ligne 2 et on copie les données de X, Y et Z

Quelles sont les cellules X, Y et Z?
12/10/2012, 14h52
JiBé91

Autant pour moi, en fait la je travail sur une feuille test, donc au fur et a mesure des essais les données varies...

Voila ce dont j'ai besoin:

Si D1 du classeur "Test" est vide on insère une ligne vide à la place de la ligne 2 dans le classeur "appro matiere" et on copie les données de A1, B1 et C1

Si D3 du classeur "Test" est vide on insère une ligne vide à la place de la ligne 2 dans le classeur "appro matiere" et on copie les données de A3, B3 et C3

ainsi de suite...

Fais le test avec ce code tel (sans aucune adaptation) et fais un feedback. (Lance la sub Main)
Je commenterai ensuite avec des explications

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx"
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                       'vérifier que le fichier existe bel et bien
    Set Entree = Workbooks.Open(Fichier)         'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 1 To 19 Step 2                   'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("D" & i)
        Next i
    End With
    Entree.Close True                            'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    Set Entree = Nothing                         'on libère la variable Entree
End If
End Sub
 
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
If IsEmpty(c) Then
    With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("A2:C2").Value = c.Offset(0, -3).Resize(1, 3).Value
    End With
End If
End Sub

12/10/2012, 15h47
JiBé91

ça marche parfaitement. :D

par contre, autant je comprenais a peu pres mon code "archaïque" que la je ne comprends plus grand chose :s

Lis attentivement chaque ligne de code et le commentaire qui l'accompagne

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
'Procédure principale
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\Appro matiere.xlsx"
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                         'vérifier que le fichier existe bel et bien
    Set Entree = Workbooks.Open(Fichier)           'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 1 To 19 Step 2
            'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            'et on fait appel à la procédure paramétrée COPIEDONNES qu'on applique à notre classeur Appro matieres.xlxs
            'contenu dans la variable Entree en prenant compte à chaque tours de boucle de la cellule D1, D3,D5...
            COPIEDONNEES Entree, .Range("D" & i)
        Next i                                     '
    End With
    Entree.Close True                              'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    Set Entree = Nothing                           'on libère la variable Entree
End If
End Sub
 
'La procédure COPIEDONNES prends en paramètre un classeur Wbk et une cellule c
'En fonction de la cellule c, on insère une ligne à la place de la ligne 2 dans la feuille Feuil1 de notre classeur Wbk
'Ensuite, on copie les données des cellules A,B,C de la même ligne que c vers A2:C2 de Feuil1 toujours de notre classeur Wbk
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
If IsEmpty(c) Then
    With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("A2:C2").Value = c.Offset(0, -3).Resize(1, 3).Value
    End With
End If
End Sub

J'arrive tant bien que mal a intégré mon code, j'ai apporté quelques modifs qui marchent (en orange). Qu'en penses tu?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\test final\Appro matieres.xlsx"
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                       'vérifier que le fichier existe bel et bien
    Set Entree = Workbooks.Open(Fichier)         'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 7 To 35 Step 2                   'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("AC" & i)
        Next i
    End With
    Entree.Close True                            'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    Set Entree = Nothing                         'on libère la variable Entree
End If
End Sub
 
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
If IsEmpty(c) Then
    If Not IsEmpty(c.Offset(0, -26)) Then
        With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("A2").Value = c.Offset(0, -28).Resize(1, 1).Value
        .Range("B2").Value = c.Offset(0, -26).Resize(1, 1).Value
        .Range("C2").Value = c.Offset(1, -26).Resize(1, 1).Value
        .Range("D2").Value = c.Offset(0, -21).Resize(1, 1).Value
        .Range("E2").Value = c.Offset(0, -16).Resize(1, 1).Value
        .Range("F2").Value = c.Offset(0, -11).Resize(1, 1).Value
        .Range("G2").Value = c.Offset(0, -8).Resize(1, 1).Value
        .Range("H2").Value = c.Offset(0, -5).Resize(1, 1).Value
        .Range("I2").Value = c.Offset(0, -3).Resize(1, 1).Value
        End With
    End If
End If
End Sub

Dans chaque ligne copié j'aimerais ajouter des cellules aux coordonnées fixe. Comment faire? J'ai essayé en reprenant mon "code" mais en vain...

Citation:

Dans chaque ligne copié j'aimerais ajouter des cellules aux coordonnées fixe

Par exemple si tu veux copier la cellule A1 vers J2 de la ligne qui vient d'être insérée

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
If IsEmpty(c) And Not IsEmpty(c.Offset(0, -26)) Then
    With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("A2").Value = c.Offset(0, -28).Value
        .Range("B2").Value = c.Offset(0, -26).Value
        .Range("C2").Value = c.Offset(1, -26).Value
        .Range("D2").Value = c.Offset(0, -21).Value
        .Range("E2").Value = c.Offset(0, -16).Value
        .Range("F2").Value = c.Offset(0, -11).Value
        .Range("G2").Value = c.Offset(0, -8).Value
        .Range("H2").Value = c.Offset(0, -5).Value
        .Range("I2").Value = c.Offset(0, -3).Value
        .Range("J2").Value = c.Parent.Range("A1") 'ICI EXEMPLE
    End With
End If
End Sub

Impec !!!

voila mon code completement intégré: (si ça peut aider une autre personne)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "C:\Documents and Settings\user\Bureau\Travaux excel\test final\Appro matieres.xlsx"
 
Call Enregistrement
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                          'vérifier que le fichier existe bel et bien
    Set Entree = Workbooks.Open(Fichier)            'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 7 To 35 Step 2                      'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("AC" & i)
        Next i
    End With
    Entree.Close True                               'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    ActiveWorkbook.Close savechanges:=True          'On ferme le classeur actif
    Set Entree = Nothing                            'on libère la variable Entree
 
End If
End Sub
 
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
If IsEmpty(c) Then
    If Not IsEmpty(c.Offset(0, -26)) Then
        With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("B2").Value = c.Offset(0, -28).Resize(1, 1).Value
        .Range("C2").Value = c.Offset(0, -26).Resize(1, 1).Value
        .Range("D2").Value = c.Offset(1, -26).Resize(1, 1).Value
        .Range("E2").Value = c.Offset(0, -21).Resize(1, 1).Value
        .Range("G2").Value = c.Offset(0, -16).Resize(1, 1).Value
        .Range("F2").Value = c.Offset(0, -11).Resize(1, 1).Value
        .Range("H2").Value = c.Offset(0, -8).Resize(1, 1).Value
        .Range("I2").Value = c.Offset(0, -5).Resize(1, 1).Value
        .Range("J2").Value = c.Offset(0, -3).Resize(1, 1).Value
        .Range("M2").Value = c.Offset(0, 0).Resize(1, 1).Value
        .Range("A2").Value = c.Parent.Range("Y4")
        .Range("K2").Value = c.Parent.Range("AC4")
        .Range("L2").Value = c.Parent.Range("AG3")
        End With
    End If
End If
End Sub
 
Private Sub Enregistrement()
 
    Sheets("Feuil1").Unprotect "SERTA"              ' Dévérouillage de la feuille
 
    If IsEmpty(Range("AA3")) Then                   ' Ajout de la date
    Range("AA3").Value = Date
 
    End If
 
    Sheets("Feuil1").Protect "SERTA"                ' Vérouillage de la feuille
 
    If IsEmpty(Range("AC4")) Then                   ' Si le client n'est pas renseigné
    MsgBox "Case ""Client"" non renseignée"
 
    ElseIf IsEmpty(Range("Y4")) Then                ' Si le numéro de commande n'est pas renseigné
    MsgBox "Case ""Commande n°"" non renseignée"
 
    ElseIf IsEmpty(Range("X3")) Then                ' Si le nom du lanceur n'est pas renseigné
    MsgBox "Case ""Lancé par"" non renseignée"
 
    ElseIf IsEmpty(Range("AG3")) Then               ' Si la date de livraison n'est pas renseignée
    MsgBox "Case ""A livrer le"" non renseignée"
 
    Else
 
        ' Sheets("Feuil1").PrintOut , , 1           ' Pour imprimer
 
        Dim NomFichier As String                    ' Pour enregistrer fichier selon cellule et dans dossier spécifié
 
        NomFichier = Range("Y4").Text & " - " & Range("AC4").Text
 
        ActiveWorkbook.SaveAs "C:\Documents and Settings\user\Bureau\Travaux excel\test final\ENREGISTREMENT\" & NomFichier
 
 
    End If
 
End Sub

Je vais continuer mon projet et reviendrais certainement pour faire face a d'autres soucis ;)

Merci à Mercatog et à Corona

16/10/2012, 13h28
mercatog

Ce n'est plus utile d'utiliser les Resize dans ton cas
au lieu de

Code:

c.Offset(0, -28).Resize(1, 1).Value

Mets simplement

Code:

c.Offset(0, -28).Value

J'ai apporté les modifs que tu m'as dites. Il me reste deux bugs régler.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Sub Main()
Dim i As Long
Dim Entree As Workbook
Const Fichier As String = "\\Srvserta\SERTA PARTAGE\GESTION MATIERE\Appro matieres.xlsm"
 
Call Enregistrement
 
Application.ScreenUpdating = False
If Dir(Fichier) <> "" Then                          'vérifier que le fichier existe bel et bien
    Set Entree = Workbooks.Open(Fichier)            'on ouvre le fichier Appro matiere.xlsx
    With ThisWorkbook.Worksheets("Feuil1")
        For i = 7 To 35 Step 2                      'on parcourt toutes les cellules de notre plage D1,D3...D19 (Adapte le 19 à ta plage)
            COPIEDONNEES Entree, .Range("AC" & i)
        Next i
    End With
    Entree.Close True                               'On ferme le fichier Appro matiere.xlsx en enregistrant les modifications
    ActiveWorkbook.Close savechanges:=True          'On ferme le classeur actif
    Set Entree = Nothing                            'on libère la variable Entree
 
End If
End Sub
 
Private Sub COPIEDONNEES(ByVal Wbk As Workbook, ByVal c As Range)
 
Sheets("Feuil1").Unprotect "SERTA"
 
If IsEmpty(c) Then
    If Not IsEmpty(c.Offset(0, -26)) Then
        With Wbk.Sheets("Feuil1")
        .Rows(2).Insert Shift:=xlDown
        .Range("B2").Value = c.Offset(0, -28).Value
        .Range("C2").Value = c.Offset(0, -26).Value
        .Range("D2").Value = c.Offset(1, -26).Value
        .Range("E2").Value = c.Offset(0, -21).Value
        .Range("G2").Value = c.Offset(0, -16).Value
        .Range("F2").Value = c.Offset(0, -11).Value
        .Range("H2").Value = c.Offset(0, -8).Value
        .Range("I2").Value = c.Offset(0, -5).Value
        .Range("J2").Value = c.Offset(0, -3).Value
        .Range("M2").Value = c.Offset(0, 0).Value
        .Range("A2").Value = c.Parent.Range("Y4")
        .Range("K2").Value = c.Parent.Range("AC4")
        .Range("L2").Value = c.Parent.Range("AG3")
        End With
    End If
End If
 
Sheets("Feuil1").Protect "SERTA"
 
End Sub
 
Private Sub Enregistrement()
 
    Sheets("Feuil1").Unprotect "SERTA"              ' Dévérouillage de la feuille
 
    If IsEmpty(Range("AA3")) Then                   ' Ajout de la date
    Range("AA3").Value = Date
 
    End If
 
    Sheets("Feuil1").Protect "SERTA"                ' Vérouillage de la feuille
 
    If IsEmpty(Range("AC4")) Then                   ' Si le client n'est pas renseigné
    MsgBox "Case ""Client"" non renseignée"
 
    ElseIf IsEmpty(Range("Y4")) Then                ' Si le numéro de commande n'est pas renseigné
    MsgBox "Case ""Commande n°"" non renseignée"
 
    ElseIf IsEmpty(Range("X3")) Then                ' Si le nom du lanceur n'est pas renseigné
    MsgBox "Case ""Lancé par"" non renseignée"
 
    ElseIf IsEmpty(Range("AG3")) Then               ' Si la date de livraison n'est pas renseignée
    MsgBox "Case ""A livrer le"" non renseignée"
 
    Else
 
        Sheets("Feuil1").PrintOut , , 1           ' Pour imprimer
 
        Dim NomFichier As String                    ' Pour enregistrer fichier selon cellule et dans dossier spécifié
 
        NomFichier = Range("Y4").Text & " - " & Range("AC4").Text
 
        ActiveWorkbook.SaveAs "\\Srvserta\SERTA PARTAGE\GESTION MATIERE\ENREGISTREMENT\" & NomFichier
 
 
    End If
 
End Sub

Le premier concerne cette ligne la:

Code:

.Range("D2").Value = c.Offset(1, -26).Value

La cellule "C" s'étend sur quatre colonnes et deux lignes.
Les cellules copiées qui sont sur la meme "double" ligne, elle, ne sont pas forcément fusionnée. Donc quand l'offset est de (0, x) ça ne pose pas de probleme il prend automatique la plus haute. Mais si l'offset est de (1, x), il ne prend pas la cellule qui se trouve en dessous de celle avec l'offset de (0, x) mais celle encore en dessous. Pas étonnant puisque l'offset s'applique à partir de la cellule "C" qui elle est fusionnée. Comment puis je palier a ça? (je sais pas si j'ai été tres explicite...)

Le second bug concerne, je pense un probleme d'identification de feuil ou de workbook. Lorsque j'éxécute ma macros, si j'ai le malheur d'avoir le classeur "Appro matiere" d'ouvert la partie de la macros suivante s'exécute sur le classeur "Appro matiere". Si ce classeur n'est pas ouvert, aucun probleme.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Private Sub Enregistrement()
 
    Sheets("Feuil1").Unprotect "SERTA"              ' Dévérouillage de la feuille
 
    If IsEmpty(Range("AA3")) Then                   ' Ajout de la date
    Range("AA3").Value = Date
 
    End If
 
    Sheets("Feuil1").Protect "SERTA"                ' Vérouillage de la feuille
 
    If IsEmpty(Range("AC4")) Then                   ' Si le client n'est pas renseigné
    MsgBox "Case ""Client"" non renseignée"
 
    ElseIf IsEmpty(Range("Y4")) Then                ' Si le numéro de commande n'est pas renseigné
    MsgBox "Case ""Commande n°"" non renseignée"
 
    ElseIf IsEmpty(Range("X3")) Then                ' Si le nom du lanceur n'est pas renseigné
    MsgBox "Case ""Lancé par"" non renseignée"
 
    ElseIf IsEmpty(Range("AG3")) Then               ' Si la date de livraison n'est pas renseignée
    MsgBox "Case ""A livrer le"" non renseignée"
 
    Else
 
        Sheets("Feuil1").PrintOut , , 1           ' Pour imprimer
 
        Dim NomFichier As String                    ' Pour enregistrer fichier selon cellule et dans dossier spécifié
 
        NomFichier = Range("Y4").Text & " - " & Range("AC4").Text
 
        ActiveWorkbook.SaveAs "\\Srvserta\SERTA PARTAGE\GESTION MATIERE\ENREGISTREMENT\" & NomFichier
 
 
    End If
 
End Sub

17/10/2012, 11h07
Philippe Tulliez

Bonjour,
A propos de

Citation:

Le second bug concerne, je pense un probleme d'identification de feuil ou de workbook. Lorsque j'éxécute ma macros, si j'ai le malheur d'avoir le classeur "Appro matiere" d'ouvert la partie de la macros suivante s'exécute sur le classeur "Appro matiere". Si ce classeur n'est pas ouvert, aucun probleme.

Pour éviter des catastrophes, lorsqu'on écrit ou on lit des valeurs dans une ou plusieurs cellules il est impératif de préciser sur quelle feuille ET sur quel classeur.
Donc cette ligne est dangereuse et explique ton problème

Code:

Sheets("Feuil1").Unprotect "SERTA"

Par exemple ce code précise que c'est la feuille("Feuil1") du classeur où se trouve le code VBA.

Code:

ThisWorkBook.Sheets("Feuil1").Unprotect "SERTA"

Il est conseillé de définir en début de procédure une variable Objet qui sera plus simple à utiliser
17/10/2012, 11h43
JiBé91

Ok, et ça se met a toutes les sauces?
par exemple:
ThisWorkbook.Sheets("Feuil1").If...
ThisWorkbook.Sheets("Feuil1").Call Enregistrement
etc...
17/10/2012, 11h50
Philippe Tulliez
Bonjour,

Citation:

Envoyé par JiBé91

Ok, et ça se met a toutes les sauces?
par exemple:
ThisWorkbook.Sheets("Feuil1").If...
ThisWorkbook.Sheets("Feuil1").Call Enregistrement
etc...

Non pas à toutes les sauces, seulement en lieu et place de range(adresse) ou worksheets(laFeuille) ou encore range(adresse)
Petit exemple d'une écriture sur la cellule A1 de la feuille Feuil1 du classeur où se trouve le code VBA
Code:

1 2 3 4 5 6 Option Explicit Dim sht As Worksheet Sub main() Set sht = ThisWorkbook.Worksheets("Feuil1") sht.Range("A1") = "Salut Toto" End Sub
17/10/2012, 12h51
Didier Gonard

Bonjour,

Citation:

Envoyé par JiBé91

Et comme de bien entendu, comme tout débutant je souhaite mettre la charue avant les boeufs...
.../... Ok, et ça se met a toutes les sauces?

Pour remettre les bœufs au bon endroit et devenir un maître sauce, vois ces tutoriels ;)

Programmer efficacement avec Excel en VBA http://bidou.developpez.com/tutoriels/ExcelVBA/
44 pages

Support de cours complet pour le VBA d'Excel http://bidou.developpez.com/article/VBA/
233 pages

cordialement,

Didier

Voir 40 message(s) de cette discussion en une page