[Iska]

Он забирает имена у клеток ранее названных. »

Он тупо назначает имена, начиная с «_1», на адреса ячеек.

Можно ли это исправить? »

Исправить-то можно. Я ориентировался на:

вопрос, который звучит в шапке изначально. нужно определенному диапазону клеток размером 50 столбцов на 2000 строк присвоить произвольные имена. » »

Я рассчитывал именно на то, что сие будет однократным действием.

Я понимаю, Вы никак не хотите манипулировать целыми диапазонами, а в обязательном порядке давать имена исключительно отдельным ячейкам (хотя я не вижу в этом требовании никакой необходимости). Впрочем, дело Ваше, пусть будет так, пробуйте:

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

Код:

Option Explicit

Sub CopyFromExcel()
    Dim objExcel As Excel.Application
    Dim objWorksheet As Excel.Worksheet
    Dim objCell As Excel.Range
    
    Dim strNewName As String
    Dim i As Long
    
    
    Set objExcel = GetObject(, "Excel.Application")
    Set objWorksheet = objExcel.Selection.Worksheet
    
    If objWorksheet.Type = Excel.xlWorksheet Then
        i = objWorksheet.Names.Count
            
        For Each objCell In objExcel.Selection
            If Not RangeHasName(objCell) Then
                Do
                    strNewName = "_" & CStr(i)
                    
                    i = i + 1
                    
                    If Not NameExists(objWorksheet, strNewName) Then
                        Exit Do
                    End If
                Loop
                
                objWorksheet.Names.Add strNewName, "=" & objCell.Address(, , Excel.xlR1C1, True)
            End If
        Next
        
        objExcel.Selection.Copy
        
        Selection.PasteSpecial , True, , , wdPasteRTF
        
        objExcel.CutCopyMode = False
    End If
    
    Set objWorksheet = Nothing
    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

Iska, начал активно пользоваться скриптом и заметил, что часто вылетает ошибка как скрине. Отчего? »

Опишите условия, при которых сие происходит.