Option Explicit
 'this line makes it cap insensitive in your string selection
Option Compare Text

Sub Check_Values_1()
    On Error Resume Next

    Dim CurCell As Range
    Dim Heading As String
    Dim Prompt As String
    Dim Criteria As Variant
    Dim Color As Long


    Dim lRows As Long
    Dim lCols As Long
    Dim lAllCells As Long
    Dim a As Integer

    lRows = ActiveSheet.Rows.Count
    lCols = ActiveSheet.Columns.Count
    lAllCells = lRows * lCols

     '   Ensure that that the entire sheet was not selected
     '   This would slow the loop down considerably
    If Selection.Cells.Count = lAllCells Then
        MsgBox "To check the entire sheet, please select only one cell", 64
        Exit Sub
    End If


     ' Loop through each cell in the selection and color
     ' as desired
    If Selection.MergeArea.Cells.Count > 1 Then
        For Each CurCell In Selection
            a = a + 1
            CurCell.Value = a
            MsgBox (a)
        Next CurCell
'    Else
'        For Each CurCell In ActiveSheet.UsedRange
'             'If you don't make a selection, it checks all cells on the sheet with values
'            If CurCell.Value = Criteria Then CurCell.Interior.ColorIndex = Color
'        Next CurCell
  End If
End Sub
Sub HYNTA()
Dim i As Long
For i = 1 To 2
  MsgBox Cells(i, 1).MergeArea.Cells(1, 1).Value & " - " & Cells(i, 2).Value
Next i
End Sub
Sub NewHYNT()
 Dim rngToCheck As Range, rngCell As Range, rngChecked As Range, a As Integer

    Set rngToCheck = Selection

    If rngToCheck.Count > 1 Then
    Set rngChecked = [IV65000]
    For Each rngCell In rngToCheck.Cells
   If Not rngCell.MergeCells Then
     a = a + 1
            rngCell.Value = a
            MsgBox (a)

   ElseIf rngCell.MergeCells Then
            If Intersect(rngCell, rngChecked) Is Nothing Then
             a = a + 1
            rngCell.Value = a
            MsgBox (a)
                rngCell.Select
                Set rngChecked = Union(rngChecked, rngCell.MergeArea)

            End If
        End If
    Next rngCell



        End If
End Sub



Sub seltable()
'
' seltable Ìàêðîñ
'
' Ñî÷åòàíèå êëàâèø: Ctrl+o

    If TypeName(Selection) <> "Range" Then Exit Sub
    On Error Resume Next
'   Check the cells with constants
    For Each cell In Selection.SpecialCells(xlConstants, 23)
        If cell.Value < 0 Then cell.Font.Bold = True Else cell.Font.Bold = False
    Next cell
'   Check the cells with formulas
    For Each cell In Selection.SpecialCells(xlFormulas, 23)
        If cell.Value < 0 Then cell.Font.Bold = True Else cell.Font.Bold = False
    Next cell

End Sub
Sub wordgo()

Dim wordApp As Object

Set wordApp = GetObject(, "Word.Application")

Selection.Copy
wordApp.Selection.PasteSpecial Link:=True, DataType:=20, Placement:=wdInLine, DisplayAsIcon:=False
End Sub


Sub rang()
Dim r As Range
For n = 1 To r.Rows.Count
    If r.Cells(n, 1) = r.Cells(n + 1, 1) Then
        MsgBox "Duplicate data in " & r.Cells(n + 1, 1).Address
    End If
Next n
End Sub