Creer qr code d'un plage de donnée

Version imprimable

J'ai un souci pour crée des qrcode pour une liste d'identifiant

je vous explique pour l'instant j'ai un document ou il y a entre autre 2 colonne : la premiere avec l'identifiant et la seconde avec les codes correspondant à la premiere en forme de police

Voila j'aimerai remplacer les codes barres par les QRcodes pour des raisons pratiques.

J'ai réussi à créer en VBA pour creer un qr code pour la premiere cellule de ma liste mais pas pour les autres
Code:

1 2 3 4 5 6 7 8 9 Sub QR() Dim Link As String Link = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & ActiveSheet.Range("B3").Value Worksheets("Feuil1").Range("C3").Activate Worksheets("Feuil1").Pictures.Insert (Link) End Sub
aprés j'aimerai adapter la taille du qrcode généré

et j'aimerai de plus que ça soit généré automatiquement quand quelque chose est écris dans la colonne 1.

Bonjour,

Une façon de faire.
Dans la Feuil1 insérer ce code:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Private Sub Worksheet_Change(ByVal Target As Range) '--- mise à jour sur changement de l'id en colonne 1 If Target.Column = 1 Then QR Target.Row End If End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) '--- mise à jour sur double-clic de l'id en colonne 1 If Target.Column = 1 Then QR Target.Row End If End Sub
et dans un module, celui-ci:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub QR(kr As Long) Dim sID As String, sLink As String, sPict As Object With ActiveSheet sID = .Cells(kr, 1) sLink = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & sID .Cells(kr, 3).Activate Set sPict = .Pictures.Insert(sLink) With sPict .Name = "QR_" & sID .Width = 60 .Height = 60 End With .Cells(kr + 1, 1).Activate Set sPict = Nothing End With End Sub
Vu qu'il faut un certain temps pour que l'image du QR code se charge, il n'est pas simple de faire une mise à jour de tous les QR code en une fois. Il est plus simple de le faire pièce à pièce à l'aide du double-clic.
Il n'est pas vérifié qu'il n'y a pas de doublon au niveau des id.
Attention: vu que les images ne sont pas transparentes, certaines peuvent se superposer sans que cela soit visible!
Le code ci-dessus ne s'est pas occupé de supprimer l'image éventuellement déjà déposée (et peut donc provoquer des superpositions).

Bonne continuation.

30/09/2017, 12h34
amandon

1 pièce(s) jointe(s)

J'ai essayé mais ça n'a pas l'air de fonctionner mais je pense qui'il beug. je vous joint le fichier.
je pense que techniquement il serait plus simple d'avoir un bouton pour actualiser les QRCODE plutot que de double cliquer sur les cases.

je vous remercie d'avance

1 pièce(s) jointe(s)

Oui, cela ne fonctionne pas vu que les textes des codes étaient censés se trouver en colonne 1.
Une version améliorée, avec les codes inscrits en colonne 2, et qui supprime les QRcodes qui sont "modifiés" dans une cellule.
Il y a du code VBA à la fois dans un module et dans la feuille Feuil1.

Dans le module;

Code:

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
Option Explicit
 
Public sQR As String '--- pour conserver valeur code avant sa modification
 
Sub QR_LigneActive()
   QRCODE ActiveCell.Row
End Sub
 
Sub QRCODE(kr As Long)
   Dim sID As String, sLink As String, sPict As Object
   With ActiveSheet
      sID = .Cells(kr, 2)        '--- 2 = colonne où se trouve le texte à traiter
      If sID = "" Then Exit Sub  '=== EXIT SUB ===
      SupprimerQR "QR_" & sID
      sLink = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & sID
      .Cells(kr, 3).Activate
      Set sPict = .Pictures.Insert(sLink)
      With sPict
         .Name = "QR_" & sID
         '--- change la taille
         .Width = 60
         .Height = 60
         '--- change la position
         .Left = .Left + 5
         .Top = .Top + 5
         '--- pour info
         Debug.Print .Name & " ajouté", , .Left, .Top
      End With
      .Cells(kr + 1, 2).Activate
      Set sPict = Nothing
   End With
End Sub
 
Sub ListerShapes()
   Dim shape As Excel.shape
   For Each shape In ActiveSheet.Shapes
      Debug.Print shape.ID, shape.Name
   Next
End Sub
 
Sub SupprimerQR(sCode As String)
   '--- supprime image ayant le même nom,
   '--- mais ne supprime pas image qui se trouverait à la même place avec un autre nom
   '--- chose qui se produit lorsque l'on change le texte du code dans la cellule
   '--- => utiliser Worksheet_SelectionChange() pour détecter le code avant modification
   Dim shape As Excel.shape
   For Each shape In ActiveSheet.Shapes
      If shape.Name = sCode Then
         Debug.Print sCode & " supprimé ID:"; shape.ID
         shape.Delete
      End If
   Next
End Sub

Dans la feuille Feuil1:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
   '--- mise à jour sur changement de l'id en colonne 2
   If Target.Column = 2 Then
      SupprimerQR "QR_" & sQR
      QRCODE Target.Row
   End If
End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   '--- mise à jour sur double-clic de l'id en colonne 2
   If Target.Column = 2 Then
      QRCODE Target.Row
   End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   sQR = Target.Value   '--- récupère la valeur du code avant sa modification
End Sub

Bonne continuation.

30/09/2017, 18h33
amandon

Super merci beaucoup

il y a un petit soucis d'erreur d'exécution 13 quand je selectionne plusieurs case c'est pas bloquant mais pénible

et pour le bouton est ce possible qu'il actualise toute les cases sachant que dans la colonne 2 ça n'ira pas plus loin que 25 N°DEFGEN.

Bonne soirée

Cordialement

1 pièce(s) jointe(s)

Pour le problème de la sélection multiple:
Code:

1 2 3 Private Sub Worksheet_SelectionChange(ByVal Target As Range) sQR = Target.Cells(1, 1).Value '--- récupère la valeur du code avant sa modification End Sub
mais cela fera une mise à jour uniquement pour la cellule qui se trouve dans le coin supérieur gauche de la plage sélectionnée (et pas pour toute la plage sélectionnée).

Pour faire une mise à jour de tous les codes inscrits dans la plage B6:B30 (soit 25 valeurs)
Code:

1 2 3 4 5 6 7 8 Sub ToutReprendre() Dim rPlage As Range, rCell As Range Set rPlage = Range("B6:B30") '--- plage à traiter For Each rCell In rPlage QRCODE rCell.Row DoEvents Next End Sub
mais il est possible qu'Excel se bloque si la connexion internet est lente.

Bonne continuation.

19/11/2017, 13h02
re

QR Code même dimension quel que soit le texte

Bonjour,
La macro fonctionne très bien, merci à vous, quelle adaptation possible pour que le QR code généré ai toujours la même dimension quel que soit la longueur du texte ?
Autre petite astuce comment faire pour que les cellules soient dimensionnées à la hauteur et largeur du QR code généré ? (la 2éme question est autorisée ? ;-)
Merci