Sub Макрос1()
    Selection.TextToColumns Destination:=Range("F6"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End Sub

Sub мяу()
    Dim ar
    ar = Selection.Value
    If Not IsArray(ar) Then
        ReDim ar(1 To 1, 1 To 1)
        ar(1, 1) = Selection.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target.Offset(-1), Me.ListObjects(1).ListColumns(3).Range) Is Nothing Then
        Target.Offset(0, -2).Resize(, 2) = Array(Format(Now, "dd mmmm yyyy"" ã."), Format(Now, "hh:nn"))
    End If
End Sub

Sub slomas1()
    Dim bbb()
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Array(1, 2, 1, 3)
    For i = 1 To 4
        If dic.exists(ar(i - 1)) Then
            ReDim bbb(2)
            bbb = dic.Item(ar(i - 1))
            bbb(1) = 1000
            dic.Item(ar(i - 1)) = bbb
        Else
            ReDim bbb(2)
            For j = 0 To 2
                bbb(j) = j * 2
            Next
            dic(dic.Count) = bbb
        End If
    Next
   it = dic.Items
   k = dic.keys
End Sub

Public WithEvents app  As Application
Public fName$

Private Sub app_WorkbookOpen(ByVal Wb As Workbook)
Dim NewExcel As Object
fName = ActiveWorkbook.FullName
If fName = ThisWorkbook.FullName Then Exit Sub
Set NewExcel = CreateObject("Excel.Application")
NewExcel.Visible = True
ActiveWorkbook.Close False
DoEvents
NewExcel.Workbooks.Open fName
End Sub

Private Sub Workbook_Open()
Set app = Excel.Application

End Sub

With ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$C"), , xlYes)
    With .ListColumns("Униграмма").Range(1)
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:="Униграмма (лемма)  - это исходная форма слова. "
    End With
End With