Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос по убийству ссылок на сторонние excel файлы, Помогите оптимизировать код
 
#1
26.02.2017 07:40:38
Коллеги, добрый день.

Пишу вам с целью проконсультироваться в вопросе оптимизации кода макроса. В связи с необходимостью на работе в екселе очень часто нужно убивать ссылки на сторонние excel файлы для того, чтобы в последствии избегать ошибок, когда рабочий файл начнет ссылаться на отсутствующие файлы. Для этого я написал следующий макрос. Скорость работы данного макроса меня устраивает, когда дело касается обработки небольших файлов, но когда мне нужно убить ссылки в файлах +1000 строк Excel зависает и все ломается. Как его оптимизировать, если это можно сделать я сам не знаю, поэтому и обратится за помощью к вам.
Код макроса:
Код
Sub RefDelList()

Dim im As Range, m As Range

Set myrange = ActiveSheet.UsedRange

For Each cell In myrange
    Dim icell As Range
    Set icell = myrange.Find(What:="*xls*", _
    LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=True)
On Error Resume Next
    'icell.Style = "Normal"
    icell.Value = icell.Value
Next

End Sub

Заранее спасибо,

P.S. Прошу прощения за слишком частое использование слова файл
 
 
 
#2
26.02.2017 08:08:34
1. Зачем все это городить, если есть штатное средство Edit Links , которое позволяет в том числе убить и связь с конкретным файлом, но возможно этому есть причина.
2. Вам надо цикл делать не по всем ячейкам используемой области, а повторять поиск и замену до тех пор пока Find не вернет Nothing Range.Find  
По вопросам из тем форума, личку не читаю.
 
 
 
#3
26.02.2017 08:13:45
Здравия. Не претендую на оптимальность. Как вижу.
Скрытый текст
Я в курсе об ограничении метода Union.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#4
26.02.2017 08:34:39
ваще не оригинально , прям по гайду
Код
Sub RefDelList()
on error goto err1   
    With Application
        CalcOld = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set myrange = ActiveSheet.UsedRange
    Dim icell As Range
    
    Set icell = myrange.Find(What:=".xls", _
    LookIn:=xlFormulas, LookAt:=xlPart, MatchCase:=False)
    If Not icell Is Nothing Then
        firstAddress = icell.Address
        Do
            icell.Value = icell.Value
            Set c = myrange.FindNext(icell)
        Loop While Not icell Is Nothing And icell.Address <> firstAddress
    End If
err1:
    With Application
        .Calculation = CalcOld
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Изменено: БМВ - 26.02.2017 09:54:16
По вопросам из тем форума, личку не читаю.
 
 
 
#5
26.02.2017 09:28:19
Del
Изменено: Sanja - 26.02.2017 09:33:16
Согласие есть продукт при полном непротивлении сторон
 
 
 
#6
26.02.2017 09:41:43
Цитата
obratka написал: нужно убивать ссылки на сторонние excel файлы

Цитата
БМВ написал: которое позволяет в том числе убить и связь с конкретным файлом
Что убить-то нужно? Ссылки в формулах? Заменить формулы на значения?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
26.02.2017 09:53:23
Цитата
Sanja написал:
Ссылки в формулах? Заменить формулы на значения?
Так при удалении автоматом замена идет на значения. я про это.

А судя по коду так и надо, другое дело, что это действо по всей книге разорвет связи, а могу допустить что хочется только в определенной области.
По вопросам из тем форума, личку не читаю.
 
 
 
#8
26.02.2017 11:03:42
Убьём все. На всякий случай
Скрытый текст
Изменено: Sanja - 26.02.2017 11:26:42
Согласие есть продукт при полном непротивлении сторон
 
 
 
#9
26.02.2017 11:48:55
Код
Sub мяу()
    Dim arr1, arr2
    Dim i&, j&
    With ActiveSheet.UsedRange
        arr1 = .Formula
        arr2 = .Value
        For i = 1 To UBound(arr1)
            For j = 1 To UBound(arr1, 2)
                If InStr(arr1(i, j), "xls") Then arr1(i, j) = arr2(i, j)
            Next
        Next
        .Cells(1).Resize(.Rows.Count, .Columns.Count) = arr1
    End With
End Sub
 
 
 
#10
28.02.2017 09:03:17
Коллеги, спасибо за ответы!

Попробую ваши советы!
 
 
 
Страницы: 1
Наверх