Copie d'un groupe d'image vers un autre classeur

**Titigre** · 12/10/2012, 11h05

Bonjour,

Voici mon problème :
J'ai deux classeurs.
Dans le premier, on va l'appeler source, j'ai un onglet avec une image (ou un groupe d'image ou des images groupée).
Je voudrais copier les images uniquement si elles sont comprises dans un ensemble de lignes, dans un classeur cible.
Je ne connais pas le nombre d'images à copier, ni leur nom.
Le code VBA est dans le classeur cible.

voilà ce que j'ai pu coder...

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
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
89
90
91
92
93
94
95
96
 
' xlsheet est déjà renseigné et correspond à une feuille de mon classeur cible
' LigneImportIMG est le numéro de la ligne où insérer mon  (mes) image(s)
 
Sub ImporterPagesIC(strFichier As String)
 
 
    'ouvre le classeur et la feuille de présentation
    Dim Wbk As Workbook
    Dim WbS As Worksheet
    Dim onglet As String
    Dim nbSel As Integer
 
    On Error GoTo ERR
 
        Set Wbk = Workbooks.Open(FileName:=strFichier, ReadOnly:=True)
        If Not Existe(Wbk, "Pages présentation") Then
            Do
                onglet = InputBox("Veuillez indiquer le nom de l'onglet contenant les pages de présentation.", "Nom de l'onglet", "Nom de l'onglet")
            Loop Until Existe(Wbk, onglet) = False
            Set WbS = Wbk.Worksheets(onglet)
        Else
            Set WbS = Wbk.Worksheets("Pages présentation")
        End If
 
 
 
        'Recherche si elle contient des pages d'Identification de composants        
        Dim i As Integer, IMG As Integer
        Dim HPB As HPageBreak
        Dim ADR As Long, row As Long, RowIMG As Long
 
        'Commence page 4 => on va chercher la ligne du 3eme saut de page
        For i = 3 To WbS.HPageBreaks.Count
            'Mémorise la ligne du saut de page
            ADR = WbS.HPageBreaks(i).Location.row
            For row = 4 To 7
                RowIMG = row + ADR
                'Le titre de la page se trouve dans une cellule fusionnée de A à O
                If WbS.Range("A" & RowIMG).MergeArea.Address = "$A$" & RowIMG & ":$O$" & RowIMG Then
                    If WbS.Range("A" & row + ADR) = "IDENTIFICATION DES COMPOSANTS" Or WbS.Range("A" & row + ADR).value = "DESIGNATION OF COMPONENTS" Then
                        'On est bien sur une page d'identification des composants
                        'Il faut maintenant créer une page d'identification des composants et insérer l'image trouvée
                        CreerIdentificationComposants
                        PageComposants = PageComposants + 1
                        nbSel = 0
                        'On selectionne toutes les images contenues entre ADR+4 et wbs.hpagebreaks(I+1).location.row recherche l'image
                        For IMG = 1 To WbS.Shapes.Count
                            'récupère la ligne de la première cellule occupée par l'image
                            Debug.Print "Limite de la page : lignes " & ADR & " à " & WbS.HPageBreaks(i + 1).Location.row
                            RowIMG = Right(WbS.Shapes(IMG).TopLeftCell.Address, Len(WbS.Shapes(IMG).TopLeftCell.Address) - InStr(2, WbS.Shapes(IMG).TopLeftCell.Address, "$"))
                            Debug.Print "Image : " & RowIMG
                            If RowIMG > ADR And RowIMG < WbS.HPageBreaks(i + 1).Location.row Then
                                WbS.Shapes(IMG).Select False
                                Debug.Print WbS.Shapes(IMG).Name
                                nbSel = nbSel + 1
                            End If
                        Next IMG
 
                        ' *********ERREUR A PARTIR DE LA*********
                        'On groupe la sélection si ce n'est pas un groupe afin de garder l'agencement des images 
                        '
                        'If nbSel > 1 Then
                        '    On Error Resume Next
                            Selection.Group.Select
                        '    If ERR > 0 Then
                        '        Debug.Print "Images séléctionnées : " & nbSel & " - Erreur lors du group"
                        '        'MsgBox "pb"
                        '    End If
                        'End If
                        Selection.Copy
                        xlsheet.Range("A" & LigneImportIMG).Select
                        xlsheet.Paste
                        xlsheet.Range("A" & LigneImportIMG).PasteSpecial
                        'Selection.Ungroup
                        ' *********** Comment ne plus  sélectionner les images ? *************
                        'Selection.Clear
                        'Shape.Ungroup
                        Exit For
                    End If
                End If
            Next row
        Next i
 
        Wbk.Close False
    Exit Sub
 
ERR:
    Dim alog As New log
    alog.Enregistrer "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
    Debug.Print "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
    MsgBox "Une erreur est survenue lors de l'importation : " & Chr(10) & ERR.Description & Chr(10), vbCritical, "Erreur lors de l'importation"
    ERR.Clear
    Wbk.Close False
 
End Sub

Merci d'avance pour l'aide que vous pourrez m'apporter.

**Titigre** · 15/10/2012, 10h10

Salut,

J'ai trouvé ma solution, et je la partage :

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
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
 
' xlsheet est déjà renseigné et correspond à une feuille de mon classeur cible
' LigneImportIMG est le numéro de la ligne où insérer mon  (mes) image(s)
 
Sub ImporterPagesIC(strFichier As String)
 
 
    'ouvre le classeur et la feuille de présentation
    Dim Wbk As Workbook
    Dim WbS As Worksheet
    Dim onglet As String
    Dim nbSel As Integer
    Dim TabIMG() As Variant 'Tableau qui contiendra le nom des images à importer
 
 
    On Error GoTo ERR
 
        Set Wbk = Workbooks.Open(FileName:=strFichier, ReadOnly:=True)
        If Not Existe(Wbk, "Pages présentation") Then
            Do
                onglet = InputBox("Veuillez indiquer le nom de l'onglet contenant les pages de présentation.", "Nom de l'onglet", "Nom de l'onglet")
            Loop Until Existe(Wbk, onglet) = False
            Set WbS = Wbk.Worksheets(onglet)
        Else
            Set WbS = Wbk.Worksheets("Pages présentation")
        End If
 
 
 
        'Recherche si elle contient des pages d'Identification de composants        
        Dim i As Integer, IMG As Integer
        Dim HPB As HPageBreak
        Dim ADR As Long, row As Long, RowIMG As Long
 
        'Commence page 4 => on va chercher la ligne du 3eme saut de page
        For i = 3 To WbS.HPageBreaks.Count
            'Mémorise la ligne du saut de page
            ADR = WbS.HPageBreaks(i).Location.row
            For row = 4 To 7
                RowIMG = row + ADR
                'Le titre de la page se trouve dans une cellule fusionnée de A à O
                If WbS.Range("A" & RowIMG).MergeArea.Address = "$A$" & RowIMG & ":$O$" & RowIMG Then
                    If WbS.Range("A" & row + ADR) = "IDENTIFICATION DES COMPOSANTS" Or WbS.Range("A" & row + ADR).value = "DESIGNATION OF COMPONENTS" Then
                        'On est bien sur une page d'identification des composants
                        'Il faut maintenant créer une page d'identification des composants et insérer l'image trouvée
                        CreerIdentificationComposants
                        PageComposants = PageComposants + 1
                        nbSel = 0
                        'On selectionne toutes les images contenues entre ADR+4 et wbs.hpagebreaks(I+1).location.row recherche l'image
                        For IMG = 1 To WbS.Shapes.Count
                            'récupère la ligne de la première cellule occupée par l'image
                            Debug.Print "Limite de la page : lignes " & ADR & " à " & WbS.HPageBreaks(i + 1).Location.row
                            RowIMG = Right(WbS.Shapes(IMG).TopLeftCell.Address, Len(WbS.Shapes(IMG).TopLeftCell.Address) - InStr(2, WbS.Shapes(IMG).TopLeftCell.Address, "$"))
                            Debug.Print "Image : " & RowIMG
                            If RowIMG > ADR And RowIMG < WbS.HPageBreaks(i + 1).Location.row Then
                                ReDim Preserve TabIMG(nbSel)
                                TabIMG(nbSel) = WbS.Shapes(IMG).Name
                                nbSel = nbSel + 1                           
                            End If
                        Next IMG
 
                       If nbSel > 1 Then
                            WbS.Shapes.Range(TabIMG).Group.Copy
                        Else
                            WbS.Shapes(TabIMG(0)).Copy
                        End If
 
                        pSommaire.Range("A" & LigneImportIMG).Select
                        pSommaire.Paste
                        Exit For
                    End If
                End If
            Next row
        Next i
 
        Wbk.Close False
    Exit Sub
 
ERR:
    Dim alog As New log
    alog.Enregistrer "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
    Debug.Print "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
    MsgBox "Une erreur est survenue lors de l'importation : " & Chr(10) & ERR.Description & Chr(10), vbCritical, "Erreur lors de l'importation"
    ERR.Clear
    Wbk.Close False
 
End Sub

Copie d'un groupe d'image vers un autre classeur [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager