أسهل الطرق لعمل الدوائر الحمراء

[سليم حاصبيا]

جرب هذا الماكرو أو بالأحرى (3 ماكرو)

Sub AddValidationCirclesForPrinting()
Dim My_cel As Range
Dim My_rg As Range
Dim My_Count As Integer
Dim My_Shape As Shape
On Error Resume Next
'=========================================
For Each My_Shape In Application.ActiveSheet.Shapes
    If My_Shape.Name Like "InvalidData_*" Then
        My_Shape.Delete
    End If
Next
'====================================
Set My_rg = Application.ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation)
If My_rg Is Nothing Then Exit Sub

My_Count = 0
For Each My_cel In My_rg
    If Not My_cel.Validation.Value Then
        Set My_Shape = Application.ActiveSheet.Shapes.AddShape(msoShapeOval, My_cel.Left - 1, My_cel.Top - 1, My_cel.Width - 1, My_cel.Height - 1)
              With My_Shape
                 .Fill.Visible = msoFalse
                 .Line.ForeColor.SchemeColor = 10
                 .Line.Weight = 1.25
                 My_Count = My_Count + 1
                 .Name = "InvalidData_" & My_Count
            End With
    End If
Next
End Sub
Sub RemoveValidationCircles()
Dim xShape As Shape
For Each xShape In Application.ActiveSheet.Shapes
    If xShape.Name Like "InvalidData_*" Then
        xShape.Delete
    End If
Next
End Sub
Sub print_for_me()
 Answer = InputBox("Do you want to print the red cerles press Y or N", "Salim You Ask", "Y/N")
     If UCase(Answer) = "N" Then
        RemoveValidationCircles
        ActiveSheet.PrintPreview
        '          ActiveSheet.PrinOut
    ElseIf UCase(Answer) = "Y" Then
        AddValidationCirclesForPrinting
         ActiveSheet.PrintPreview
      '          ActiveSheet.PrinOut
     Else
        MsgBox "Choose Y or N"
     End If
End Sub

مرفق ملف كمثال

Add_remove_PrintPreview.rar

[الزباري]

جزاك الله خيراً