Sub AddCheckboxes()

    Dim targetRange As Range
    Dim cell As Range
    Dim checkbox As Object
    Dim response As VbMsgBoxResult
    Dim defaultAddress As String
    
    defaultAddress = Selection.Address
    
    On Error Resume Next
    Set targetRange = Application.InputBox("محدوده مورد نظر براي ايجاد چک باکس ؟", Default:=defaultAddress, Type:=8)
    On Error GoTo 0
    
 
    If targetRange Is Nothing Then
        Exit Sub
    End If
    
  
'    If targetRange.Cells.Count = 1 Then
'        MsgBox "تک سلول انتخاب شده است لطفا محدوده انتخاب کنيد ", vbInformation + vbMsgBoxRight, "officebaz.ir"
'        Exit Sub
'    End If
    
    For Each cell In targetRange
        If cell.Value <> "" Then
            response = MsgBox("محدوده انتخابي داراي اطلاعات است ، جايگزين شود ؟ ", vbYesNo + vbMsgBoxRight + vbExclamation, "officebaz.ir")
            If response = vbNo Then Exit Sub
            Exit For
        End If
    Next cell
    
    For Each cell In targetRange.Cells
  
        cell.Font.Color = cell.Interior.Color
        
        Set checkbox = ActiveSheet.CheckBoxes.Add(cell.Left, cell.Top, cell.Width, cell.Height)
        
        With checkbox
            .LinkedCell = cell.Address
            .Caption = ""
            .Name = "chk_" & cell.Address
            .Width = 14
            .Height = 14
            .Top = cell.Top + (cell.Height - .Height) / 2
            .Left = cell.Left + (cell.Width - .Width) / 2
        End With
    Next cell

End Sub