Macro de verification données images

[roidurif]

Bonjour,

j'aimerais rajouter une macro pour retranscrire cela et qui vérifie :

- La colonne Photo (BD) doit etre renseigné :
d'un préfixe "le numéro de contrat cellule A"_ "nom de l'image" extension ".jpg ou .gif "
ex : 1233_photo_stylo.jpg
les espaces blancs sont interdit
=> si format different par exemple :
"photo_stylo.jpg" (ne contient pas le numéro client de la colonne A) ou
"1233 photo stylo " (ne contient pas d'extention .jpg ou .gif) ou
"1233 photo stylo.gif " (ne contient pas d' underscore (_) au lieu des espace ( )ou

Alors inscrire "Numéro célulle" dans l' onglet feuil2 (Nom Image incohérent)

merci d avance

Cdt

 

[roidurif]

Re : Macro de verification données images

Bonjour PMO2,

J'ai saisie le code dont vous m'avez dit et ca bloque à cette même ligne lorsque tous les noms d'images sont biens renseignés sans aucunes erreures. Je sais pas pourquoi ça le fait quand c'est bien renseigné.

[COLOR="Blue"]
Set R = S.Range("P12:P" & UBound(T, 2) + 12 - 1 & "")
[/COLOR]

Merci


Cordialement.

 

[PMO2]

Re : Macro de verification données images

Bonjour,

Le code modifié ci-dessous

Sub CleanImages() 'Contrôle Format Images


Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
  bool = False
  A$ = var(i&, 56) 'commodité d'écriture
    If A$ <> "" Then
    If LCase(Right(A$, 4)) <> ".jpg" And _
       LCase(Right(A$, 4)) <> ".gif" Then bool = True
    If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
    If var(i&, 1) = "" Then bool = True
    If InStr(1, A$, Chr(160)) Then bool = True
    If InStr(1, A$, Space(1)) Then bool = True
    If InStr(1, A$, "_") = 0 Then bool = True
    If bool Then
      cpt& = cpt& + 1
      ReDim Preserve T(1 To 1, 1 To cpt&)
      If REF_ABS Then
        Ref$ = "$BD$"
      Else
        Ref$ = "BD"
      End If
      T(1, cpt&) = Ref$ & i&
    End If
  End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("p12:p65536").ClearContents
If cpt& > 0 Then  'modif
  Set R = S.Range("P12:P" & UBound(T, 2) + 12 - 1 & "")
  R = WorksheetFunction.Transpose(T)
End If            'modif
MsgBox ("Terminé")
End Sub

Cordialement.

PMO
Patrick Morange