Sub essai()
Dim i As Long
Dim j As Long
'---------------------------
'efface
With Feuil1.Columns("C:CP")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Feuil1.Shapes.SelectAll
Selection.Delete
'Remet bouton action
With Feuil1.Buttons.Add(1.8, 1.2, 119.4, 16.8)
.OnAction = "nouvelleaction"
.Characters.Text = "Nouvelle Action"
With .Characters(Start:=1, Length:=15).Font
.Name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
End With
'------------------------
For k = 6 To 18 Step 6 'boucle sur type action
For i = 2 To Feuil2.Range("A" & Rows.Count).End(xlUp).Row 'boucle sur BD
For j = 3 To Feuil1.Cells(4, Cells.Columns.Count).End(xlToLeft).Column 'boucle sur dates
'identification dates actions
If (Feuil1.Cells(k, 1) = Feuil2.Cells(i, 2) And Feuil1.Cells(4, j) = Feuil2.Cells(i, 13)) Then
'encadre
With Feuil1.Range(Cells(k - 1, j), Cells(k + 1, j))
.BorderAround Weight:=xlThin
End With
'Shapes
'Shapes
Feuil1.Shapes.AddTextbox(msoTextOrientationHorizontal, j * 6, k * 6, 50, 20).Name = "monshape" & Feuil2.Cells(i, 3).Value
With ActiveSheet.Shapes("monshape" & Feuil2.Cells(i, 3).Value)
.TextFrame.Characters.Text = Feuil2.Cells(i, 3).Value
.Fill.ForeColor.RGB = RGB(255, 255, 0)
.TextFrame.Characters.Font.Size = 8
End With
End If
End If
Next
Next
Next
End Sub