VBA: Déterminer si une cellule contient un objet

[MJ13]

Bonjour à tous

J'ai un fichier avec dans la colonne B des noms de fichiers avec pour certaines des images.

Comment faire en VBA pour savoir si la cellule contient une image ou un objet de façon à supprimer les lignes n'en contenant pas ?

Merci d'avance.

 

[Pierrot93]

Re : VBA: Déterminer si une cellule contient un objet

Bonjour Michel🙂

perso, je ne connais pas de moyen de savoir si une cellule contient un objet ou pas... Mais regarde peut être le code ci-dessous si tu peux t'en inspirer, boucle sur les objets de la feuille, stocke dans un objet "range" les adresses des cellules sur lesquelles sont posées les objets et boucle sur la colonne b (plage à adapter) afin de déterminer si la cellule fait partie de la plage contenant les divers objets :

Option Explicit
Sub test()
Dim maplage As Range, s As Shape, c As Range
For Each s In Feuil1.Shapes
    If maplage Is Nothing Then
        Set maplage = Range(s.TopLeftCell.Address, s.BottomRightCell.Address)
    Else
        Set maplage = Union(maplage, Range(s.TopLeftCell.Address, _
            s.BottomRightCell.Address))
    End If
Next s
For Each c In Range("B1:B50")
    If Intersect(c, maplage) Is Nothing Then MsgBox "vide " & c.Address
Next c
End Sub

bonne soirée
@+

 

[MJ13]

Re : VBA: Déterminer si une cellule contient un objet

Bonjour Pierrot

Merci pour le code, mais avec mon petit niveau, j'ai pas trop réussi, je ne maîtrise pas trop.

Mais j'ai retrouvé un code dans une de mes anciennes demande dont voici le code qui permet de mettre le nom de l'objet à sa droite(Je remercie Mutzig au passage):

Sub test1()
'par Mutzig adaptation MJ pour [URL]https://www.excel-downloads.com/threads/localisation-dun-objet.95931/[/URL]
Dim sh As Shape
For Each sh In Sheets(ActiveSheet.Name).Shapes()
'MsgBox sh.TopLeftCell.Address
Range(sh.TopLeftCell.Address).Select
ActiveCell.offset(0,6).Value = sh.Name
Next
End Sub

Je met en offset(0,6) le nom de l'objet.

Puis je teste sur la colonne 8 et je supprime les lignes vides.
Mais avec 40000 lignes c'est asssez long 😱!

Sub supprime_lignes_sans_images()
derl = Cells(65536, 1).End(xlUp).Rows.Row
'Stop
For i = derl To 1 Step -1
If Cells(i, 8) = "" Then Rows(i).Delete
Next
End Sub

Si quelqu'un a une autre idée, je suis preneur.

Bon Week-end 🙂.

 

[Pierrot93]

Re : VBA: Déterminer si une cellule contient un objet

Re

Aarf, sans doute pas tout compris moi... Mets peut être un tout petit fichier en pièce jointe représentant le problème posé... Ce sera plus facile pour t'apporter une solution... D'après ce que j'avais compris, tu modifiais la ligne du "msgbox" par un "delete" et c'était bon....

@+

 

[MJ13]

Re : VBA: Déterminer si une cellule contient un objet

Re

Voici un exemple:

Le but est de supprimer les lignes sans objet (mais je peux avoir 50 000 lignes).

 

[Pierrot93]

Re : VBA: Déterminer si une cellule contient un objet

Re

essaye ceci :

Option Explicit
Sub test()
Dim maplage As Range, s As Shape, c As Long
Application.ScreenUpdating = False
For Each s In Feuil1.Shapes
    If maplage Is Nothing Then
        Set maplage = Range(s.TopLeftCell.Address, s.BottomRightCell.Address)
    Else
        Set maplage = Union(maplage, Range(s.TopLeftCell.Address, _
            s.BottomRightCell.Address))
    End If
Next s
For c = Range("B65536").End(xlUp).Row To 1 Step -1
    If Intersect(Cells(c, 2), maplage) Is Nothing Then Rows(c).Delete
Next c
Application.ScreenUpdating = True
End Sub

bonne soirée
@+

 

[MJ13]

Re : VBA: Déterminer si une cellule contient un objet

Re Pierrot

Merci beaucoup. T'es un chef Macros 🙄.

J'ai testé sur 6000 lignes et cela à l'air de fonctionner. Je testerai lundi sur un plus gros fichier.

Bon Week-end 🙂.

 

[MJ13]

Re : VBA: Déterminer si une cellule contient un objet

Bonjour à tous

Pierrot:
Bon, après quelques tests, ta solution fonctionne bien jusqu'à quelques mlliers de lignes mais sur une grande plage, de 50000 lignes, c'est trop long. Dans ce cas la solution du post#3 semble fonctionner (une quinzaine de minutes pour 50 000 lignes et 40 000 objets).

C'est encore long mais bon, on s'en contentera et sinon, il vaut peut-être mieux supprimer les lignes sans images à l'origine 🙄!

Bonne journée 🙂.

 

[Pierrot93]

Re : VBA: Déterminer si une cellule contient un objet

Bonjour Michel

pour accélérer essaye peut en désactivant le calcul auto, mais il me semble que dans ton fichier exemple il n'y en avait pas....

Application.Calculation = xlCalculationManual
'le code
Application.Calculation = xlCalculationAutomatic

sinon pas d'autre idée
@+

 

[MJ13]

Re : VBA: Déterminer si une cellule contient un objet

Re Pierrot

Non, je n'ai pas de calcul. Il s'agit d'insérer des images .jpg à partir du non de dossier en colonne A et du nom de fichier en colonne B.

Voici le code que j'ai fait gràce à un code de MichelXLD.

Sub Insere_Imgs()
'MJ
'Stop
Efface_Images
For Each cell In Range("B2:B" & Cells(65536, 2).End(xlUp).Rows.Row)
cell.Select
If Right(cell, 4) = ".jpg" Or Right(cell, 4) = ".JPG" Or Right(cell, 4) = ".Jpg" Then Insere_redimensionne_Image
Next
'Redimensionne_Images_avec_Cellules
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize
Cells(1, 1).Select
Cells(2, 1).Select
End Sub
Sub Insere_redimensionne_Image()
'MichelXLd adaptation MJ
'La  Dll wiaaut.dll doit être chargée (voir lien çi dessous).
'http://www.microsoft.com/downloads/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29&DisplayLang=en
Dim Img As Object, IP As Object
On Error Resume Next
Kill "C:\Thumb" & ActiveCell
'Stop
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
'Img.LoadFile "C:\Documents and Settings\michel\dossier\fourmiz.JPG"
Img.LoadFile ActiveCell.Offset(0, -1) & "\" & ActiveCell
IP.Filters.Add IP.FilterInfos("Scale").FilterID
'mettre ici les valeurs de largeur et hauteur d'image
IP.Filters(1).Properties("MaximumWidth") = Cells(1, 11)
IP.Filters(1).Properties("MaximumHeight") = Cells(1, 11)
Set Img = IP.Apply(Img)
'Img.SaveFile "C:\Documents and Settings\michel\dossier\fourmizThumbnail.JPG"
Img.SaveFile "C:\Thumb" & ActiveCell
'problème sur Xl2007
ActiveSheet.Pictures.Insert("C:\Thumb" & ActiveCell).Select
'Pour XL2007 Décocher les 2 lignes suivantes
'Selection.Cut
'ActiveSheet.Paste
'Pour Xl2007
Kill "C:\Thumb" & ActiveCell
End Sub

Mais je pense qu'avec les solutions des posts #3 et 6, cela devrait aller.

Encore Merci 🙂.