Bordures automatique dans tableau
Bonjour le Forum,
Dans un classeur j'ai 2 feuilles,
1 Feuil1 nommé "Article"
1 Feuil2 nommé "Catalogue"
La feuil1 sert de BDD et la Feuil2 de catalogue avec affichage d'image en colonne B, le principe par ex, est de cliquer sur le cellule L1 pour afficher l'ensemble du catalogue qui va des A à E et les lignes sont aléatoires (par rapport a la base de donnée)
Il est possible aussi de trier l'affiche par 4 catégorie en cliquant en H1, ou I1, ou J1, ou K1.
Je suis arrivé à créer le code pour l'affichage mais j'aimerai maintenant ajouter les bordures des cellules, je n'y arrive pas !!! grr pourriez vous m'apporter un peu d'aide svp ?
Voici mon code :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell = Range("H1") Or ActiveCell = Range("I1") Or ActiveCell = Range("J1") Or ActiveCell = Range("K1") Then
Range("G2:L2").Value = "" 'efface
Range("G8:L8").Value = "" 'efface
Range("G3").Value = "" 'efface
Range("M2:M7").Value = "" 'efface
Range("H9:L9").Value = "" 'efface
Range("H1:L1").Interior.ColorIndex = 15 'remet la couleur gris
ActiveCell.Interior.ColorIndex = 44
For Each Shape In ActiveSheet.Shapes
Shape.Delete
Next
[A2:E100].Clear
'----- Alignement du texte
With Range("A2:E100")
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
With Range("D2:D100")
.WrapText = True
.HorizontalAlignment = xlHAlignLeft
End With
rep = ThisWorkbook.Path & "\img\"
famille = ActiveCell.Value
Ligne = 2 'ligne feuil 1
i = 2 'ligne feuil 2
Do While Sheets(1).Cells(Ligne, 1).Value <> ""
If Sheets(1).Cells(Ligne, 10).Value = famille Then
Sheets(2).Cells(i, 1).Interior.ColorIndex = 36
Sheets(2).Cells(i, 1).Value = Sheets(1).Cells(Ligne, 2).Value
Sheets(2).Cells(i, "B").Select
fichier = Sheets(2).Cells(i, 1).Value & ".jpg"
Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
Image.Name = fichier
ActiveSheet.Shapes(fichier).Height = 50
ActiveSheet.Shapes(fichier).Width = 50
Rows(i & ":" & i).RowHeight = 50
Image.OnAction = "image_cliquer"
Sheets(2).Cells(i, 3).Value = Sheets(1).Cells(Ligne, 3).Value 'prix
Sheets(2).Cells(i, 3).NumberFormat = "# ##0.00 €"
Sheets(2).Cells(i, 4).Value = Sheets(1).Cells(Ligne, 4).Value 'designation
Sheets(2).Cells(i, 5).Value = Sheets(1).Cells(Ligne, 8).Value 'a commander mini
End If
i = i + 1
Ligne = Ligne + 1
Loop
Range("M1").Value = (i - 2) & Chr(10) & "Articles trouvés"
Range("F1").Select
End If
If ActiveCell = Range("L1") Then
ThisWorkbook.Workbook_Open
End If
End SubMerci à vous
Cdlt
pompaero
Bonsoir,
Tu disposes de la propriété Borders et de la méthode BorderAround pour les bordures. Tu regardes leur utilisation, puis tu réfléchis à ce que tu veux obtenir au final pour choisir la façon de les placer la plus courte à écrire (et qui a des chances d'être aussi la plus rapide...)
Par exemple, tu bordes ta plage en traits fins, sauf le tour en épais et une colonne que tu entoures en medium... Tu ne vas pas distinguer les différents morceaux en raison du résultat final de chacun, tu commences par traits fins pour toute la plage, puis l'encadrement de ta colonne en médium (qui remplacera le fin), puis le tour en épais (qui remplacera le fin ou le médium selon les endroits). En procédant ainsi tu auras 2 à 3 fois moins de code à écrire...
Je vois aussi (entre autres choses...) beaucoup de répétitions dans ton code qui justifieraient un usage plus étendu de blocs With... des ActiveCell ou ActiveSheet, qui n'ont aucune raison de figurer dans une évènementielle ou tu disposes de Target et de Me pour la feuille...
Cordialement.
Bonjour MFerrand
Merci de ta participation à mon post et pour ta réponse.
J'essai de regarder à ça tranquillement.
Cordialement
pompaero
Bonjour le forum
Je reviens vers vous car je n'arrive pas à résoudre le montage tout seul, je ne sais pas si c'est le fait que la macros efface tout à son départ au autre !!!
J'aimerai avoir les bordures de cellule des colonne A à K sur le les lignes qui s'affiche, svp ?
Je joins un fichier exemple.
Merci par avance
Cordialement
pompaero
Salut Pompaero,
voilà ton fichier que j'ai quelque peu amélioré.
Tout ce qui concerne la mise en page ne doit pas être répété sans cesse : tu fixes ces paramètre à la création de ta feuille et tu oublies. Je t'en ai laissé pour ne pas trop t'inquiéter...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim sWkA As Worksheet
Set sWkA = Worksheets("Article")
'
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("K1:K4")) Is Nothing Then
Range("K1:K4").Interior.ColorIndex = 15 'remet la couleur gris
Target.Interior.ColorIndex = 44
Range("G2").Value = "Catalogue " & Target & " " & Year(Now())
'
For Each Shape In ActiveSheet.Shapes
Shape.Delete
Next
[A6:K100].ClearContents
[A6:A100].Interior.Color = xlNone
Range("A6:K100").Borders.LineStyle = xlLineStyleNone
'
rep = ThisWorkbook.Path & "\img\"
famille = Target.Value
Ligne = 2 'ligne feuil 1
i = 5 'ligne feuil 2
With sWkA
Do While .Cells(Ligne, 1).Value <> ""
If .Cells(Ligne, 11).Value = famille Then
i = i + 1
Cells(i, 1).Interior.ColorIndex = 36
Cells(i, 1).Value = .Cells(Ligne, 2).Value
'Cells(i, "B").Select
fichier = .Cells(i, 1).Value & ".jpg"
' Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
' Image.Name = fichier
' ActiveSheet.Shapes(fichier).Height = 30
' ActiveSheet.Shapes(fichier).Width = 30
For x = 3 To 11
iCol = Choose(x, 0, 0, 4, 3, 8, 12, 6, 5, 7, 10, 9)
Cells(i, x).Value = .Cells(Ligne, iCol).Value
Next
Cells(i, 4).NumberFormat = "# ##0.00" ' €"
End If
Ligne = Ligne + 1
Loop
End With
iRow = Range("A" & Rows.Count).End(xlUp).Row
Rows(6 & ":" & iRow).RowHeight = 30
Range("A6:K" & iRow).Borders.LineStyle = xlContinuous
Range("B6").Select
End If
'
Application.ScreenUpdating = True
'
End SubA+
Bonjour, Salut Curulis,
Devant me déplacer, je n'ai guère le temps pour le moment... Mais tu n'es pas abandonné, je vois...
Bonjour curulis57
Merci de ton aide, le code est très allégé, lol
Je vois que tu ma laissé la partie des image à gérer, (si j'ai bien compris !!) donc après essai je n'arrive pas a adapter.
Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
Image.Name = fichier
ActiveSheet.Shapes(fichier).Height = 30
ActiveSheet.Shapes(fichier).Width = 30j'ai tenté entre autre ceci
Cells(i, "B") = ActiveSheet.Pictures.Insert (rep & fichier)mais déjà la, ça bug.
pompaero
Bonjour curulis57, MFerrand, le forum
Désolé, je reviens vers vous pour l'affichage des images dans le code de curulis, si j'active le
Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
Image.Name = fichier
ActiveSheet.Shapes(fichier).Height = 30
ActiveSheet.Shapes(fichier).Width = 30ça bug !!! et j'ai tenté d'autres solutions, ça bug aussi, grrrr je ne vois plus comment faire.
est il possible d'avoir un peu d'aide svp ?
Cordialement
pompaero
Bonjour,
Sans aller voir les détails (pas le temps en ce moment...) : sur quelle ligne l'erreur ? (ce qui pourrait en indiquer la raison...)
A noter l'indécision du code [
Cordialement.
Bonjour MFerrand
C'est une première, que je crée des images dans un fichier, alors un peu paumé..
J'ai ajouté une variable (Dim Image As Objet) mais pas sur que cela soit exacte.
et le bug se fait au niveau du (Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
mon code :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim sWkA As Worksheet
Set sWkA = Worksheets("Article")
Dim Image As Object
'
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("K1:K4")) Is Nothing Then
Range("K1:K4").Interior.ColorIndex = 15 'remet la couleur gris
Target.Interior.ColorIndex = 44
Range("G2").Value = "Catalogue " & Target & " " & Year(Now())
'
For Each Shape In ActiveSheet.Shapes
Shape.Delete
Next
[A6:K100].ClearContents
[A6:A100].Interior.Color = xlNone
Range("A6:K100").Borders.LineStyle = xlLineStyleNone
'
rep = ThisWorkbook.Path & "\img\"
famille = Target.Value
Ligne = 2 'ligne feuil 1
i = 5 'ligne feuil 2
With sWkA
Do While .Cells(Ligne, 1).Value <> ""
If .Cells(Ligne, 11).Value = famille Then
i = i + 1
Cells(i, 1).Interior.ColorIndex = 36
Cells(i, 1).Value = .Cells(Ligne, 2).Value
Cells(i, "B").Select
fichier = .Cells(i, 1).Value & ".jpg"
Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
Image.Name = fichier
ActiveSheet.Shapes(fichier).Height = 30
ActiveSheet.Shapes(fichier).Width = 30
For x = 3 To 11
iCol = Choose(x, 0, 0, 4, 3, 8, 12, 6, 5, 7, 10, 9)
Cells(i, x).Value = .Cells(Ligne, iCol).Value
Next
Cells(i, 4).NumberFormat = "# ##0.00" ' €"
End If
Ligne = Ligne + 1
Loop
End With
iRow = Range("A" & Rows.Count).End(xlUp).Row
Rows(6 & ":" & iRow).RowHeight = 30
Range("A6:K" & iRow).Borders.LineStyle = xlContinuous
Range("B6").Select
End If
'
Application.ScreenUpdating = True
'
End SubPas de raison si le chemin est bon et si le fichier existe dans le dossier spécifié ! Eléments à vérifier.
C'est une chose que j'ai déjà vérifier et ça à l'air bon
Dans un dossier nommé (Catalogue) il y a le fichier Bordure tableau.xlsm et fichier img ou se trouve les images.
Le msg d'erreur qui s'affiche est le suivant : Impossible de lire la propriété Insert de la classe Pictures
C'est bon je viens de trouver la cause !!
c'est sur cette partie, la feuille n'était pas spécifié devant le Cells juste après le i = i + 1
With sWkA
Do While .Cells(Ligne, 1).Value <> ""
If .Cells(Ligne, 11).Value = famille Then
i = i + 1
Cells(i, 1).Interior.ColorIndex = 36
Cells(i, 1).Value = .Cells(Ligne, 2).Value
Cells(i, "B").Select
fichier = .Cells(i, 1).Value & ".jpg"
Set Image = ActiveSheet.Pictures.Insert(rep & fichier)
Image.Name = fichier
ActiveSheet.Shapes(fichier).Height = 30
ActiveSheet.Shapes(fichier).Width = 30ça à l'air de fonctionner !!
ensuite j'ai un autre petit soucis, mais je vais ouvrir un autre post.
pompaero
J'ai tout remis comme au départ, et c'est rien à y comprendre !!!!!! ça fonctionne.
Merci à vous
pompaero
Tant mieux !