Sub КопированиеНаЛистВсехЛистов_Через_Массивы_Гипперссылки_индивидуальные()
' можно добавить гиперссылки через диапазон, используя массив i_n()
Dim sht As Worksheet
Dim cell As Range
Dim j As Long, k As Long, i As Long, i1 As Long, i2 As Long
Dim j1 As Integer
Dim Razdel As String, NameSht As String
Dim i_n() As Long
Dim Tablica()
Dim shtName() As String
Dim t As Long
Time_1 = Timer
Sheets(1).Select
NameSht = "Данные по книге"
Razdel = "Розетки и выключатели."
Shapka = 2 ' номер строки шапки, за которой следует сама таблица
j1 = InputBox("Введите номер столбца, до которого мы собираемся записывать данные", "Номер столбца", "8")
If Sheets(1).Name = NameSht Then
Application.DisplayAlerts = False
    Sheets(1).Delete
Application.DisplayAlerts = True
End If
    Sheets(1).Select
    Sheets.Add Before:=ActiveSheet
    Sheets(1).Name = NameSht
    Sheets(1).Cells.ClearContents
    Sheets(2).Cells(2, 1).Resize(, j1).Copy Sheets(1).Cells(1, 1)
Application.ScreenUpdating = False
k_n = Worksheets.Count - 1
ReDim i_n(k_n)
ReDim shtName(k_n)
'________________________создание массива кол-ва строк на каждом листе______начало
For Each sht In ActiveWorkbook.Worksheets
    If sht.Index <> 1 Then
       i_n(sht.Index - 1) = sht.Cells(Rows.Count, 3).End(xlUp).Row
       shtName(sht.Index - 1) = sht.Name
       If i_nn < i_n(sht.Index - 1) Then
          i_nn = i_n(sht.Index - 1)
       End If
    End If
Next sht

'________________________создание массива кол-ва строк на каждом листе______конец
ReDim Tablica(Worksheets.Count - 1, i_nn, j1)
For Each sht In ActiveWorkbook.Worksheets
    If sht.Index <> 1 Then
      i1 = 0 'скидываем на первую строку
      For i = Shapka + 1 To i_n(sht.Index - 1)
       i1 = i1 + 1
       For j = 1 To j1
        Tablica(sht.Index - 1, i1, j) = sht.Cells(i, j)
       Next j
    '    MsgBox (Tablica(sht.Index - 1, i1, j1))
      Next i
    End If
Next sht
i2 = 1
t = 2
For k = 1 To k_n
   For i = 1 To i_n(k) - Shapka
     i2 = i2 + 1
     For j = 1 To j1
       Worksheets(1).Cells(i2, j) = Tablica(k, i, j)
     Next j
       Set cell = Worksheets(1).Cells(i2, j1 + 1)
           Worksheets(1).Hyperlinks.Add Anchor:=cell, Address:="", _
           SubAddress:="'" & shtName(k) & "'" & "!A" & Shapka + i
           cell.Formula = shtName(k)
   Next i
       Set cell = Worksheets(k + 1).Cells(1, 7)
           Worksheets(1).Hyperlinks.Add Anchor:=cell, Address:="", _
           SubAddress:="'" & Worksheets(1).Name & "'" & "!A" & t
           cell.Formula = Worksheets(1).Name
    t = i2 + 1
       With Worksheets(k + 1).Cells(1, 7).Font
            .Name = "Times New Roman"
            .Size = 12
            .Bold = True
            .Italic = True
       End With
       With Worksheets(k + 1).Cells(1, 7)
            .WrapText = True
       End With
Next k
Application.ScreenUpdating = True
          Cells.RowHeight = 15
        Rows(1).RowHeight = 55
Time_ = Time_1 - Timer
Time_delta = Format(Time_ / 24 / 60 / 60, "hh\ч mm\м ss\с")
      MsgBox ("Выполненно за " & Time_delta)
End Sub