Discussion :

[piderrien]

Bonjour à tous,

Je suis à nouveau en difficulté sur du VBA. Je souhaite consolider des tableaux relatifs à des projets à partir de leur code projet. Pour ce faire j'aimerais développer une commande qui aille rechercher ce code projet dans trois onglets (Onglet1, Onglet2 et Onglet3) d'un classeur (Classeur1) puis qui retourne le tableau entier associé à cette valeur dans un autre classeur (Classeur2). En sachant que mon code projet n'est pas forcément présent dans tous les onglets.

J'ai pour l'instant essayé ce que je pouvais à partir de l'enregistreur de macros, avec un certain nombre de problèmes détaillés dans le corps du code ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Windows("Classeur1.xlsx").Activate 
Sheets("Onglet1").Select
    Cells.Find(What:="codeprojet", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range("A76:M90").Select 'Là je suis embêté car l'enregistreur sélectionne directement la plage de cellule alors que je voudrais qu'il décale la sélection par rapport à ma recherche : je voudrais  décaler la sélection de deux lignes vers le bas, puis sélectionner le tableau formé des 12 colonnes et 15 lignes à partir de cette cellule, peut-être utiliser Offset mais comment étendre ma sélection ?
    Application.CutCopyMode = False
    Selection.Copy 'Copie la sélection
    Windows("Classeur2.xlsx").Activate 
    Range("A42").Select 
    ActiveSheet.Paste 'colle la sélection en A42
 
    Windows("Classeur1.xlsx").Activate
    Sheets("Onglet2").Select
    Cells.Find(What:="codeprojet", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range("A86:M100").Select 'Idem précédent
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Classeur2").Activate
    Range("A57").Select
    ActiveSheet.Paste 'copie 15 lignes plus bas que la copie précédente
 
 
    Windows("Classeur1.xlsx").Activate
    Sheets("Onglet3").Select
    Cells.Find(What:="codeprojet", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Windows("Classeur2.xlsx").Activate 'là rien à copier car la recherche dans Onglet3 n'a rien donné - mais comment l'automatiser si ça donne quelque chose?
 
    Selection.Rows.Ungroup
    ActiveSheet.Range("$A$41:$B$71").RemoveDuplicates Columns:=Array(1, 2), _
        Header:=xlYes
'Cette partie est pour supprimer tous les blancs (les tableaux copiés comportent plusieurs lignes blanches que je souhaite supprimer du document de destination)
End Sub

Voilà, c'est un peu compliqué pour le novice en VBA que je suis, mais je pense que la résolution n'est pas si difficile. Quelqu'un a une idée sur les points que j'ai détaillés?
Merci d'avance !

[anasecu]

Bonjour piderrien,

Voilà, c'est un peu compliqué pour le novice en VBA que je suis, mais je pense que la résolution n'est pas si difficile.

Je te propose de simplifier ainsi ta macro

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Sub copier()
Dim wb1 As Workbook, wb2 As Workbook, ws As Worksheet
Dim feu As Byte, cel As Range, lig As Long
    Set wb1 = Workbooks("Classeur1.xlsm")   'rectifier les noms
    Set wb2 = Workbooks("Classeur2.xlsx")
    Set ws = wb2.ActiveSheet
    ws.Activate
    lig = 42
    For feu = 1 To 3
        With wb1.Sheets("Onglet" & feu)
            Set cel = .Cells.Find(What:="codeprojet", After:=[A1], LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Not cel Is Nothing Then          'Copie la sélection
                cel.Offset(2, 0).Resize(15, 12).Copy _
                Destination:=ws.Range("A" & lig) 'colle la sélection à patir de A42
                lig = lig + 15
            End If
        End With
    Next feu
    ws.Range("$A$41:$B$" & lig).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End Sub

[piderrien]

Super, c'est tout à fait ce qu'il me fallait. Pour la boucle "Feu" je vais quand même dupliquer car mes onglets portent des noms spécifiques, j'avais modifié par souci de confidentialité...
Il me copie également une ligne pour le troisième onglet dans lequel (pour ma simulation), le code du projet n'est pas présent. Il indique dans cette ligne des erreurs partout. Comment est-ce que je peux enlever cette ligne dans ce cas ?

En tous cas merci pour ton aide, je vais finir par y arriver !

[anasecu]

Bonjour,

je vais quand même dupliquer car mes onglets portent des noms spécifiques,

Si tu l'avais précisé, ce n'est pas un souci et pas besoin de dupliquer comme tu vois dans la rectification.

Il me copie également une ligne pour le troisième onglet dans lequel (pour ma simulation), le code du projet n'est pas présent

Si le code est absent 'cel Is Nothing' il n'y a pas de copie !
Si tes classeurs ne sont pas ouverts tu peux le faire automatiquement.
Voilà les modifications pour te donner des idées

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Sub copier()
Dim wb1 As Workbook, wb2 As Workbook, ws As Worksheet
Dim feu As Byte, cel As Range, lig As Long, ong
ong = Split("Onglet,feuille,bilan", ",")  'rectifier les noms
    Workbooks.Open "chemin\Classeur1.xlsm"
    Set wb1 = ActiveWorkbook
    Workbooks.Open "chemin\Classeur2.xlsx"
    Set wb2 = ActiveWorkbook
    Set ws = wb2.ActiveSheet
    ws.Activate
    lig = 42
    For feu = 0 To UBound(ong)
        With wb1.Sheets(ong(feu))
            Set cel = .Cells.Find(What:="codeprojet", After:=[A1], LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Not cel Is Nothing Then          'Copie la sélection
                cel.Offset(2, 0).Resize(15, 12).Copy _
                Destination:=ws.Range("A" & lig) 'colle la sélection à patir de A42
                lig = lig + 15
            End If
        End With
    Next feu
    wb2.ActiveSheet.Range("$A$41:$B$" & lig).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End Sub

[piderrien]

Hello à nouveau,

Un grand merci pour ces informations, tu me fais avancer à pas de géant ! Il y a quelques problèmes au niveau du chemin d'accès sur la version "itérée", donc je reste sur la version "dupliquée" (je n'ai pas beaucoup d'onglets donc ça va vite en copy/paste).


Par souci du détail, je peaufine certains aspects:

1) En fait je n'ai pas besoin de copier la colonne A. J'ai donc changé la boucle avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
                cel.Offset(2, 1).Resize(15, 12).Copy _
                Destination:=ws.Range("B" & lig) 'colle la sélection à patir de A42
                lig = lig + 15

J'aimerais utiliser la colonne A vierge du fichier de destination pour insérer le nom du classeur et de l'onglet concerné pour chaque ligne.
Ça donnerait quelque chose de ce type-là (qui ne marche pas évidemment mais j'essaye de formaliser ma pensée comme ça) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
                cel.Offset(2, 1).Resize(15, 12).Copy _
                Destination:=ws.Range("B" & lig) 'colle la sélection à patir de A42
                From lig to lig + 14, colonne A  = "Classeur1-Onglet" 
                lig = lig + 15

Comme j'ai choisi de rester sur ma duplication de code je peux saisir les informations Classeur1-Onglet à la main pour chaque onglet, donc pas besoin de variable de ce côté-là. En revanche je pense que du coup après suppression des doublons il va me rester des lignes avec uniquement du classeur1-Onglet en A et rien dans le reste de la ligne... Comment supprimer ces lignes inutiles ? Une boucle If A = "Classeur1-Onglet" and B="", supprimer ligne ? (il y a toujours forcément une valeur dans B).
Je me rends compte que plutôt qu'une suppression des doublons il me faudrait une suppression de toutes les lignes avec une valeur vide dans la colonne B, si c'est possible. Ou plutôt, il me faudrait une commande améliorée de mon Resize, avec au lieu de copier 15 lignes, aller jusqu'à la première cellule vide de la colonne B et ne copier que ce qu'il y a au dessus. Ça m'éviterait même la suppression des doublons à la fin. Mais je ne sais pas sic'est possible.

2) Le "codeprojet" saisi à la main dans la macro est également saisi en A39. Comment faire pour rendre la macro dynamique pour qu'elle aille recherche non pas un "codeprojet" défini mais le contenu de la cellule A39?

Après le reste est parfait, tu me sauves la vie je n'étais pas capable de faire ça tout seul avec mes maigres connaissances!