Transferer les chiffres qui se trouvent sur une foto sur.....

[Guido]

Bonsoir le Forum

J'aimerais extraire le chiffre qui se trouvent sur une image dans une cellule,

Voir le fichier..

Merci d'avance

Guido

 

[Guido]

Re

Job75

Merci pour les corrections.

Guido

 

[job75]

Bonjour Guido, le forum,

Dans ce fichier (2) il y a un message quand toutes les courses ne sont pas transférées.

Bonne journée.

 

[Guido]

Bonjour Job75 et le Forum

J'ai une question importante....

J'ai un fichier qui importe les cotes dans mon fichier excel cotes comment je peux regrouper ,

le fichier chevaux fotos sur ce fichier cotes ou l'inverse

Merci pour votre aide.

Guido

 

[Guido]

Bonjour a Tous

job75

Le fichier pour les foto du jour

ne fonctionne pas

Merci de bien vouloir regardé quand tu as un moment

No stess,la vie est belle

Amitiées

Guido

 

[Guido]

Bonjour le Forum et Job75

Avec la version 1 elle fonctionnais...

et la ,maintenant non...???

quelle le bug ??

Merci de pouvoir m'aider

D'avance ,Merci

Guido

 

[Guido]

Bonsoir

Pas de solution ???

Tampis

Merci

Guido

 

[job75]

Bonjour Guido,

Pas de réponse car le fichier du post #34 fonctionne parfaitement.

A+

 

[Guido]

Re

Job75

Voici le fichier #34

essaie de faire fonctionner svp

Merci

 

[job75]

Re,

Même constat, même réponse, vous avez des problèmes de vue ?

Je n'irai pas plus loin.

Bonne fin de soirée.

 

[Guido]

RE

jOB75
Le probleme est le suivant...

quand je veux remplacer l'ancienne feuille ou image le bouton de la macro s'enleve

Merci

Guido

 

[job75]

Re,

Je ne sais pas ce que vous faites mais si vous voulez supprimer les Shapes :

Sub SupprimerShapes()
Dim s As Shape
For Each s In ActiveSheet.Shapes
  If s.AlternativeText Like "hippo*" Or s.AlternativeText Like "*_*" Then s.Delete
Next
End Sub

Bonne nuit.

 

[job75]

Bonjour Guido,

Puisque vous ne dites rien de ce que vous voulez faire voici une solution qui tient la route.

La macro dans le fichier "PRONOS 2016-08.xls" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim chemin$, dat$, s As Shape, lig&, col%, at$, sp, vis%
Dim c As Range, flag As Boolean, r As Range, n%, ntrans&, ncourse&
If Intersect(Target, [A4]) Is Nothing Then Exit Sub
[A4].Select
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False 'si un fichier source est déjà ouvert
Application.CopyObjectsWithCells = True 'permet la copie des objets
Me.DrawingObjects.Delete: [B:G].Clear 'RAZ
If [A4] = "" Then GoTo 1
'---copie du fichier source---
chemin = ThisWorkbook.Path & "\" 'chemin des fichiers sources, à adapter
dat = Mid(ThisWorkbook.Name, 8, 7) & "-" & Format([A4], "00")
If Not IsDate(dat) Then [A4] = "": GoTo 1
If Dir(chemin & "Courses " & dat & ".xls") = "" Then MsgBox "Aucune course ce jour-là...": GoTo 1
With Workbooks.Open(chemin & "Courses " & dat & ".xls").Sheets(1)
  .[B:D].Copy [B1]
  .[A1].Copy .[A1] 'important : vide la mémoire
  .Parent.Close False
End With
'---analyse des Shapes---
For Each s In Shapes
  lig = s.TopLeftCell.Row
  col = s.TopLeftCell.Column
  at = s.AlternativeText
  sp = Split(at, "_")
  If at Like "hippodrome*" Then
    Cells(lig + 2, 5).Resize(, 3).Interior.Color = 13434828
  ElseIf UBound(sp) > 0 Then
    If IsNumeric(sp(1)) Then
      If col = 2 Then Cells(lig, 7) = sp(1)
      If col = 3 Then Cells(lig, 6) = sp(1)
      If col = 4 Then Cells(lig, 5) = sp(1)
    End If
    Cells(lig, 5).Resize(2, 3).Interior.Color = 10079487
  End If
Next s
'---création et remplissage de la feuille des pronos---
On Error Resume Next
If IsError(Sheets(dat)) Then
  With Sheets("Modele")
    vis = .Visible 'la feuille peut être masquée
    .Visible = xlSheetVisible
    .Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = dat
    .Visible = vis
  End With
End If
On Error GoTo 0
With Sheets(dat)
  For Each c In .UsedRange
    If c = "CHX" Then c(1, 2).Resize(, 6) = "" 'RAZ
  Next c
  For Each c In Intersect([E:G], Me.UsedRange.EntireRow)
    If c.Interior.ColorIndex = xlNone Then
      flag = False
    ElseIf Not flag And c.Interior.Color = 13434828 Then
      flag = True
      sp = Split(c(-2, -2), "C") 'références de la course
      Set r = Nothing
      n = 0
      If UBound(sp) > 0 Then
        Set r = .Cells.Find(sp(0), , xlValues, xlWhole)
        If Not r Is Nothing Then Set r = r.EntireColumn.Find("Course " & sp(1))
        If Not r Is Nothing Then Set r = r(2, 2).Resize(, 6): ntrans = ntrans + 1
      End If
    ElseIf flag And Not r Is Nothing And IsNumeric(CStr(c)) Then
      n = n + 1
      If n < 7 Then r(n) = c
    End If
  Next c
  [E:G].Clear
  ncourse = Application.CountIf([C:C], "Hippodrome*")
  .Activate
End With
1 Application.EnableEvents = True
Application.ScreenUpdating = True
If ncourse <> ntrans Then MsgBox ncourse & " courses, " & ntrans & " transférées..."
End Sub

Entrez en A4 de la 1ère feuille le numéro du jour (1 2 3 etc).

Fichiers zippés joints.

Nota : les noms des fichiers ne correspondent pas aux dates des courses, c'est juste pour l'exemple.

A+

 

[Guido]

Bonjour Job75

Merci pour ta proposition.

Peux tu juste me dire que dois je inscrire dans la cellule jaune merci

a plus

Guido

 

[job75]

Re,

J'ai ajouté les Application.EnableEvents dans la macro précédente, c'est nettement plus rapide.

A+

 

[job75]

Re,

Peux tu juste me dire que dois je inscrire dans la cellule jaune

A vos lunettes Guido :

Entrez en A4 de la 1ère feuille le numéro du jour (1 2 3 etc).

Par ailleurs j'ai ajouté un bouton dans la feuille 'Modele" (contrôle de formulaire).

Cela permet de revenir facilement à la 1ère feuille.

Fichiers (2).

A+