[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

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

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

[Pozia]

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

работает. только вот если диапазон выбираю то имена не присваиваются клеткам при вставке. Это можно поправить?

[Iska]

Pozia, у меня присваивается. Описывайте подробно пример, а я попробую воспроизвести у себя.

[Pozia]

Iska, разобрался, присваивает. Просто думал что каждой ячейке в выбранном диапазоне будет присвоено имя, что предпочтительнее для меня. Так можно сделать?

[Iska]

…что каждой ячейке в выбранном диапазоне будет присвоено имя, что предпочтительнее для меня. Так можно сделать? »

А смысл?

[Pozia]

А смысл? »

для меня есть:
1. Решается вопрос, который звучит в шапке изначально. Это позволит в дальнейшем работать быстрее без скрипта там где его нет.
2. Постоянно сделав одну связь на какую то клетку, я затем в ворде просто ее копирую в другие нужные места, и связи вешаются. Если я скопирую диапазон ячеек с одним общим именем, то потом из него я не смогу копировать нужные мне ячейки в другие места документа ворд, связь повесится не верно.

Поэтому, если это возможно сделать, буду признателен. В любом случае, еще раз огромное спасибо.

Iska, правильно ли я исправил кусок кода для более наглядности:

Код:

            Do
                strNewName = "i" & CStr(i) & "i"
                If Not NameExists(.Worksheet, strNewName) Then

[Iska]

1. Решается вопрос, который звучит в шапке изначально. Это позволит в дальнейшем работать быстрее без скрипта там где его нет. »

Вставьте в проект рабочей книги и выполните:

Код:

Option Explicit

Sub SetNames()
    Dim objWorksheet As Worksheet
    Dim objCell As Range
    Dim i As Long
    
    Set objWorksheet = Selection.Worksheet
    
    If objWorksheet.Type = xlWorksheet Then
        i = 1
        
        For Each objCell In Selection
            objWorksheet.Names.Add "_" & CStr(i), "=" & objCell.Address(, , xlR1C1, True)
            
            i = i + 1
        Next
    End If
    
    Set objWorksheet = Nothing
End Sub

Решите вопрос, который звучит в шапке изначально.

Если я скопирую диапазон ячеек с одним общим именем, то потом из него я не смогу копировать нужные мне ячейки в другие места документа ворд, связь повесится не верно. »

Данное утверждение неверно. Сможете.

Iska, правильно ли я исправил кусок кода для более наглядности: »

Вы получите имена вида: «i1i», «i2i», «i3i» и т.д.

[Pozia]

Решите вопрос, который звучит в шапке изначально. »

скрипт хитрый оказался ). Он забирает имена у клеток ранее названных. То есть если уже есть имена _1, _2, _3... и я выбираю другой диапазон задать имена, то он стирает имена на прежних клетках, и дает их новым клеткам. Можно ли это исправить?

[Pozia]

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

[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, начал активно пользоваться скриптом и заметил, что часто вылетает ошибка как скрине. Отчего? »

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