Перебор листов и вставка линков в другую книгу

Пользователь

Сообщений: 20 Регистрация: 14.03.2016

22.04.2016 10:26:09

Добрый день.

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

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

Код

Sub Link_paste()
Dim DestBook As String
Dim DR As String

DestBook = "book.xlsx" ' книга из которой берем ячейку
DR = "X63" ' ячейка на которую ссылаемся

On Error GoTo Errors1

Workbooks(DestBook).Activate
Worksheets(Index + 1).Activate 'вот это повторяется от 1 до 20 раз,
  Range(DR).Select
  Selection.Copy

Workbooks("Book2.xlsm").Activate 'рабочая книга куда вставляем линк
 
  Cells(Rows.Count, 2).End(xlUp).Offset(1).Select
  ActiveSheet.Paste link:=True

Workbooks(DestBook).Activate
Worksheets(Index + 2).Activate
  Range(DR).Select
  Selection.Copy

Workbooks("Book2.xlsm").Activate
 
  Cells(Rows.Count, 2).End(xlUp).Offset(1).Select
  ActiveSheet.Paste link:=True
  
  Workbooks(DestBook).Activate
Worksheets(Index + 3).Activate
  Range(DR).Select
  Selection.Copy

Workbooks("Book2.xlsm").Activate
 
  Cells(Rows.Count, 2).End(xlUp).Offset(1).Select
  ActiveSheet.Paste link:=True
  
Errors1:  MsgBox ("Достингут конец книги")

End Sub

Изменено: Danmer - 22.04.2016 10:57:46

Sanja

Модератор

Сообщений: 16516 Регистрация: 10.01.2013

22.04.2016 11:21:35

Проверьте

Код

Sub Link_paste()
Dim CBook  As Workbook
Dim DBook As Workbook
Dim Sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
    Set CBook = Workbooks("book.xlsx")
    Set DBook = Workbooks("Book2.xlsm")
    For Each Sh In CBook.Worksheets
        Sh.Range("X63").Copy
        With DBook.ActiveSheet
            .Range("B" & .Cells(.Rows.Count, 2).End(xlUp).Row + 1).Select
            .Paste Link:=True
        End With
    Next
Application.ScreenUpdating = True
End Sub

Согласие есть продукт при полном непротивлении сторон

LVL

Пользователь

Сообщений: 904 Регистрация: 01.01.1970

22.04.2016 11:44:19

Код

Sub CreateListLinks()

Dim i As Long
Dim strTemp As String
Dim ItWb As Variant
Dim ItWhs As Variant

i = 1
For Each ItWb In Workbooks
    If ItWb.Name <> "PERSONAL.XLSB" And ItWb.Name <> ThisWorkbook.Name Then
        For Each ItWhs In ItWb.Worksheets
            i = i + 1
            strTemp = "='[" & ItWb.Name & "]" & ItWhs.Name & "'!A1"
            ActiveSheet.Cells(i, 1).Formula = strTemp
        Next
    End If
Next

End Sub

Изменено: LVL - 22.04.2016 11:44:35

Danmer Пользователь Сообщений: 20 Регистрация: 14.03.2016	#4 22.04.2016 11:45:38 Sanja, прям Вау! Спасибо! Пошел учить матчасть.

Danmer Пользователь Сообщений: 20 Регистрация: 14.03.2016	#5 22.04.2016 11:55:47 LVL, и Вам спасибо за участие. ИМХО первый код более изящный (ну и я в нем почти все понял))) В вашем варианте макрос сочиняет ссылку из названий листов открытых книг, хитро. Изменено: Danmer - 22.04.2016 11:56:09