[Iska]

Pozia, пробуйте:

читать дальше »

Код:

Option Explicit

Sub CopyFromExcel()
    Dim objExcel As Excel.Application
    Dim strAddress As String
    Dim strNewName As String
    
    Dim i As Long
    
    Set objExcel = GetObject(, "Excel.Application")
    
    With objExcel.Selection
        If .Worksheet.Type = Excel.xlWorksheet Then
            i = .Worksheet.Names.Count + 1
            
            Do
                strNewName = "_" & CStr(i)
                
                If Not NameExists(.Worksheet, strNewName) Then
                    Exit Do
                Else
                    i = i + 1
                End If
            Loop
            
            If Not RangeHasName(objExcel.Selection) Then
                .Worksheet.Names.Add strNewName, "=" & .Address(, , Excel.xlR1C1, True)
            End If
            
            .Copy
            
            Selection.PasteSpecial , True, , , wdPasteRTF
            
            .Application.CutCopyMode = False
        End If
    End With
    
    Set objExcel = Nothing
End Sub

Function NameExists(objWorksheet As Excel.Worksheet, strName As String) As Boolean
   On Error Resume Next
   
   NameExists = Len(objWorksheet.Names(strName).Name) <> 0
End Function

Function RangeHasName(objRange As Excel.Range) As Boolean
   On Error Resume Next
   
   RangeHasName = Len(objRange.Name.Name) <> 0
End Function

… при его наличие у клетки »

Будет работать с любыми диапазонами (не только состоящими из одной клетки).