Mise au point d'une macro

Version imprimable

2 pièce(s) jointe(s)

Bonjour,

Présentation du sujet :

Le classeur "devis général" a la macro dans le module 1. Les cellules des lignes 1 à 61 colonnes A à BZ sont vérrouillées et non modifiables.

Le classeur "mes devis". Les lignes 1 à 47 colonnes A à BZ sont verrouillées et non modifiables.

Sur ces 2 classeurs les cellules A et BZ sont des cellules fusionnées A=A:E et BZ=BZ:CE.

Sur chaque lignes il existe aussi d'autre cellules fusionnées entre les colonnes A et BZ.
La zone de destination posséde des formats de cellules indentiques à la zone source .

Ce que la macro doit éxécuter:
Après la saisie du "prénom", du mois et de l'ouverture du classeur "mes devis" la macro doit sélectionner dans "devis général" à partir de la ligne 62 toutes les lignes (colonnes A à BZ) qui correspondent au "prénom", et copier cette sélection dans "mes devis" à partir de la ligne 48 (colonnes A à BZ).

Exemple :
Si le prénom est Emmanuel, sélection des lignes 62 et 64 (de A à BZ) dans classeur "devis général"
Copie de ces 2 lignes dans le classeur "mes devis" à partir de la ligne 48 (colonnes A à BZ)

Lorsque j'execute la macro ci-dessous aucune copie ne se fait et aucun message d'erreur n'est renvoyé...

Je tourne en rond depuis 3 jours.....!
Merci de votre aide
Lenul78570

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
Sub copie()
'
' copie Macro
'
'
Dim prenom As String, mois As String
Dim plage As Range, cel As Range
Dim trouve As Byte
Dim reponse As Variant, Fichier As Variant
Dim Sh As Worksheet
Dim wrbo As Workbook, wrbd As Workbook
Dim wrso As Worksheet, wrsd As Worksheet
Dim chemin As String, nomfichier As String
Dim tablo() As String
Dim dl1 As Long
 
'expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type)
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez votre prénom :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, "GRRrrrr!"
            Case False
                Exit Sub
            Case Else
                Exit Do
        End Select
 Loop
prenom = reponse
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez pour quel mois vous voulez copier vos devis :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, ""
            Case False
                Exit Sub
            Case Else
 
                    For Each Sh In Worksheets
                        If Sh.Name = reponse Then trouve = 1
                    Next Sh
                If trouve = 1 Then Exit Do
                MsgBox ("Le mois demandé n'exste pas dans le classeur")
        End Select
 Loop
mois = reponse
 
Set wrbo = ThisWorkbook
Set wrso = wrbo.Sheets(mois)
 
 
Fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
If Fichier = False Then Exit Sub
Workbooks.Open Filename:=Fichier
tablo = Split(Fichier, "\")
'Affiche le chemin et le nom du fichier sélectionné.
Set wrbd = Workbooks(tablo(UBound(tablo)))
Set wrsd = wrbd.Sheets(mois)
 
Set plage = wrso.Range("BZ62:BZ" & wrso.Cells(wrso.Rows.Count, 25).End(xlUp).Row)
For Each cel In plage
    If cel = prenom Then ' pour chaque cellule avec la valeur choisie
    ' on rechherche la première cellule libre en colonne A
        dl1 = wrsd.Cells(wrsd.Rows.Count, 1).End(xlUp).Row + 1
        'on recopie la ligne
        wrso.Range("a" & cel.Row & ":bz" & cel.Row).Copy _
            Destination:=wrsd.Range("a" & dl1 & ":bz" & dl1)
 
    End If
Next cel
 
wrbd.Save
wrbd.Close
 
End Sub

J'ai une version qui fonctionne avec comme changement :

Ligne 63 :

Code:

Set plage = wrso.Range("BZ62:BZ" & wrso.Range("BZ62").End(xlDown).Row)

Ligne 67 :

Code:

If cel.Value = prenom Then

Et ligne 66 à 79 :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 For Each cel In plage If cel.Value = prenom Then ' pour chaque cellule avec la valeur choisie ' on rechherche la première cellule libre en colonne A dl1 = wrsd.Range("A47").End(xlDown).Row + 1 If dl1 = 65537 Then dl1 = 48 End If 'on recopie la ligne wrsd.Range("A" & dl1 & ":BZ" & dl1) = wrso.Range("A" & cel.Row & ":BZ" & cel.Row).Value End If Next cel
Bye !

Je ne sais pas si tu as eu le réflexe, mais lorsque tu as ce genre de problème,

Vérifie à chaque endroit de ton programme qu'il fait bien ce qu'il est censé faire.

Le mode "Pas à Pas" est idéal (raccourci F8) . Dans ce mode, passe ta souris sur les variables de ton code pour faire apparaître la valeur qu'elles prennent.

Bye

14/12/2009, 13h23
jp014

Bonjour

A tester avec le code

Code:

Set plage = wrso.Range("BZ62:BZ" & wrso.Cells(wrso.Rows.Count, 78).End(xlUp).Row)

et

Code:

dl1 = wrsd.Cells(wrsd.Rows.Count, 78).End(xlUp).Row + 1

La colonne BZ est la 78 ième et non 25.

JP014

Bonjour Sympasteve,

Merci de ton aide, ci-desous la macro modifiée selon tes conseils :

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
Sub copie()
'
' copie Macro
'
'
Dim prenom As String, mois As String
Dim plage As Range, cel As Range
Dim trouve As Byte
Dim reponse As Variant, Fichier As Variant
Dim Sh As Worksheet
Dim wrbo As Workbook, wrbd As Workbook
Dim wrso As Worksheet, wrsd As Worksheet
Dim chemin As String, nomfichier As String
Dim tablo() As String
Dim dl1 As Long
 
'expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type)
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez votre prénom :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, "GRRrrrr!"
            Case False
                Exit Sub
            Case Else
                Exit Do
        End Select
 Loop
prenom = reponse
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez pour quel mois vous voulez copier vos devis :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, ""
            Case False
                Exit Sub
            Case Else
 
                    For Each Sh In Worksheets
                        If Sh.Name = reponse Then trouve = 1
                    Next Sh
                If trouve = 1 Then Exit Do
                MsgBox ("Le mois demandé n'exste pas dans le classeur")
        End Select
 Loop
mois = reponse
 
Set wrbo = ThisWorkbook
Set wrso = wrbo.Sheets(mois)
 
 
Fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
If Fichier = False Then Exit Sub
Workbooks.Open Filename:=Fichier
tablo = Split(Fichier, "\")
'Affiche le chemin et le nom du fichier sélectionné.
Set wrbd = Workbooks(tablo(UBound(tablo)))
Set wrsd = wrbd.Sheets(mois)
 
Set plage = wrso.Range("BZ62:BZ" & wrso.Range("bz62").End(xlDown).Row)
For Each cel In plage
    If cel.Value = prenom Then ' pour chaque cellule avec la valeur choisie
    ' on rechherche la première cellule libre en colonne A
        dl1 = wrsd.Range("a47").End(exldown).Row + 1
        If dl1 = 65537 Then
        dl1 = 48
        End If
        'on recopie la ligne
        wrsd.Range("a" & dl1 & ":bz" & dl1) = wrso.range ("a" & cel.row & ":bz" & cel.row) .value
 
    End If
Next cel
 
wrbd.Save
wrbd.Close
 
End Sub

Lors de son écriture j'ai un souci avec cette ligne :

Code:

wrsd.Range("a" & dl1 & ":bz" & dl1) = wrso.range ("a" & cel.row & ":bz" & cel.row) .value

J'ai une information qui me dis : erreur de compilation - attendu fin d'instruction.
je vois pas ou est l'erreur...
Lenul78570

14/12/2009, 16h26
lenul78570

Bonjour Jp014,

J'ai donc modifié la macro mais elle affiche :
erreur d'éxécution "1004"
la méthode de Copy de la classe range a échoué

Tu vois pourquoi ?

Lenul78570

Bonjour

Ci dessous le code pour copier les données.

Code:

1
2
3
           wrso.Rows(cel.Row & ":" & cel.Row).Copy
           wrsd.Range("a" & dl1 & ":e" & dl1).Select
            ActiveSheet.Paste

A tester

JP014

14/12/2009, 17h39
lenul78570

pour jp014

Désolé même résultat, jai essayé de changer le ":e" par ":bz" mais toujours la meme erreur 1004
Heureusement que tu es là !
14/12/2009, 18h11
jp014
Bonsoir

Je n'ai pas de problème la copie se fait normalement. Il y a un message pour confirmer la copie.

Pour trouver le code copie j'ai utilisé l'enregistreur de macro. Il faudrait faire de même.Ensuite on modifie le code.

La solution basique consiste à recopier cellule par cellule en utilisant MergeArea quand les cellules sont fusionnées.
exemple
Code:

1 2 3 wrso.Cells(cel.Row, 1).MergeArea(1) = wrsd.Cells(dl1, 1).MergeArea(1) wrso.Cells(cel.Row, 6) = wrsd.Cells(dl1, 6)
JP
14/12/2009, 19h07
mercatog

sans patauger

Code:

wrsd.Range("a" & dl1 & ":bz" & dl1).value = wrso.range ("a" & cel.row & ":bz" & cel.row) .value

quand c'est un range de plusieurs cellules, il faut absolument le .Value et les 2 ranges de même dimension

Bonjour Mercatog, jp014 et sympasteve !

La macro ci-dessous fonctionne presque bien !
Le seul souci qui persiste est le suivant :
Si dans "wrso" j'ai plusieurs lignes avec le même prénom elle ne copie dans "wrsd" que la premiere et la derniere ligne.
Exemple :
Si j'ai "michel" en bz62, bz64, bz69 et bz71 les copies que j'obtiens sur "wrsd" sont celles de la ligne 62 colonnes A à BZ et ligne 71 colonnes A à BZ.
Les lignes 64 et 69 ne sonts pas copiées
Y a t il une solution ?
Lenul78570

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
Sub copie()
'
' copie Macro
'
'
Dim prenom As String, mois As String
Dim plage As Range, cel As Range
Dim trouve As Byte
Dim reponse As Variant, Fichier As Variant
Dim Sh As Worksheet
Dim wrbo As Workbook, wrbd As Workbook
Dim wrso As Worksheet, wrsd As Worksheet
Dim chemin As String, nomfichier As String
Dim tablo() As String
Dim dl1 As Long
 
'expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type)
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez votre prénom :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, "GRRrrrr!"
            Case False
                Exit Sub
            Case Else
                Exit Do
        End Select
 Loop
prenom = reponse
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez pour quel mois vous voulez copier vos devis :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, ""
            Case False
                Exit Sub
            Case Else
 
                    For Each Sh In Worksheets
                        If Sh.Name = reponse Then trouve = 1
                    Next Sh
                If trouve = 1 Then Exit Do
                MsgBox ("Le mois demandé n'exste pas dans le classeur")
        End Select
 Loop
mois = reponse
 
Application.ScreenUpdating = False
 
Set wrbo = ThisWorkbook
Set wrso = wrbo.Sheets(mois)
 
 
Fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
If Fichier = False Then Exit Sub
Workbooks.Open Filename:=Fichier
tablo = Split(Fichier, "\")
'Affiche le chemin et le nom du fichier sélectionné.
Set wrbd = Workbooks(tablo(UBound(tablo)))
Set wrsd = wrbd.Sheets(mois)
 
Set plage = wrso.Range("BZ62:BZ" & wrso.Cells(wrso.Rows.Count, 78).End(xlUp).Row)
For Each cel In plage
    If cel = prenom Then ' pour chaque cellule avec la valeur choisie
    ' on rechherche la première cellule libre en colonne A
        dl1 = wrsd.Range("a47").End(xlDown).Row + 1
        If dl1 = 65537 Then
        dl1 = 48
        End If
        'on recopie la ligne
        wrsd.Range("a" & dl1 & ":bz" & dl1).Value = wrso.Range("a" & cel.Row & ":bz" & cel.Row).Value
 
    End If
Next cel
wrbd.Save
wrbd.Close
 
End Sub

Essaie ceci

Code:

1
2
3
4
5
6
7
8
9
10
For Each cel In plage
    If cel.value = prenom Then ' pour chaque cellule avec la valeur choisie
    ' on rechherche la première cellule libre en colonne A
        dl1 = wrsd.Range("BZ65537").End(xlUp).Row + 1
        If dl1 < 48 Then dl1 = 48
        'on recopie la ligne
        wrsd.Range("a" & dl1 & ":bz" & dl1).Value = wrso.Range("a" & cel.Row & ":bz" & cel.Row).Value
 
    End If
Next cel

Nouveau bug :
erreur 1004-la méthode 'Range'de l'objet'_Worksheet' a échoué

Ci dessous la macro modifiée selon tes derniers conseils :

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
Sub copie()
'
' copie Macro
'
'
Dim prenom As String, mois As String
Dim plage As Range, cel As Range
Dim trouve As Byte
Dim reponse As Variant, Fichier As Variant
Dim Sh As Worksheet
Dim wrbo As Workbook, wrbd As Workbook
Dim wrso As Worksheet, wrsd As Worksheet
Dim chemin As String, nomfichier As String
Dim tablo() As String
Dim dl1 As Long
 
'expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type)
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez votre prénom :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, "GRRrrrr!"
            Case False
                Exit Sub
            Case Else
                Exit Do
        End Select
 Loop
prenom = reponse
Do
        reponse = Application.InputBox(Title:="Copie de mes devis", Prompt:="Indiquez pour quel mois vous voulez copier vos devis :", Type:=2, Default:="")
        Select Case reponse
            Case ""
                MsgBox "vous n'avez pas  fait de saisies!" & Chr(13) & "recommencez!", vbCritical, ""
            Case False
                Exit Sub
            Case Else
 
                    For Each Sh In Worksheets
                        If Sh.Name = reponse Then trouve = 1
                    Next Sh
                If trouve = 1 Then Exit Do
                MsgBox ("Le mois demandé n'exste pas dans le classeur")
        End Select
 Loop
mois = reponse
 
Application.ScreenUpdating = False
 
Set wrbo = ThisWorkbook
Set wrso = wrbo.Sheets(mois)
 
 
Fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
If Fichier = False Then Exit Sub
Workbooks.Open Filename:=Fichier
tablo = Split(Fichier, "\")
'Affiche le chemin et le nom du fichier sélectionné.
Set wrbd = Workbooks(tablo(UBound(tablo)))
Set wrsd = wrbd.Sheets(mois)
 
Set plage = wrso.Range("BZ62:BZ" & wrso.Cells(wrso.Rows.Count, 78).End(xlUp).Row)
For Each cel In plage
    If cel.Value = prenom Then ' pour chaque cellule avec la valeur choisie
    ' on rechherche la première cellule libre en colonne A
        dl1 = wrsd.Range("bz65537").End(xlUp).Row + 1
        If dl1 < 48 Then dl1 = 48
 
        'on recopie la ligne
        wrsd.Range("a" & dl1 & ":bz" & dl1).Value = wrso.Range("a" & cel.Row & ":bz" & cel.Row).Value
 
    End If
Next cel
wrbd.Save
wrbd.Close
 
End Sub