Sub HYP_LINKzwo()

   Sheets("Tabelle2").Select
   Range("G2").Select
   ActiveCell.FormulaR1C1 = _
       "=IFERROR(HYPERLINK(LinkAddress(INDEX(Budget!C1,MATCH(Tabelle2!RC[-6],Budget!C1),1)),""<<""),"""")"
   Range("G2").Select
   Selection.AutoFill Destination:=Range("G2:G32")
   Range("G2:G32").Select
   ActiveWorkbook.Save
End SubЗаранее спасибо за помощь!

Dim DateTime As Date
Private Sub Workbook_Open()
    TimerFlag = True 'A
    Call Timer_Tick
    DateTime = Now + #12:02:00 AM# 'B
    Application.OnTime DateTime, " Timer_TickB"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    TimerFlag = False 'A
    Application.OnTime EarliestTime:=MyEarliestTime, Procedure:="Timer_Tick", Schedule:=False
    ThisWorkbook.Save
    On Error Resume Next 'B
    Application.OnTime DateTime, " Timer_TickB", , False
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'C
    Workbook_BeforeClose False
    Workbook_Open
End Sub

Public TimerFlag As Boolean
Public MyEarliestTime As Variant
Sub Timer_Tick()
    If TimerFlag Then
        ThisWorkbook.Save
        MyEarliestTime = Now + TimeValue("00:00:05")
        Application.OnTime EarliestTime:=MyEarliestTime, Procedure:="Timer_Tick"
    End If
End Sub
Sub Timer_TickB()
ThisWorkbook.Close True
End Sub

Sub Svod_HP()
    Dim ws As Worksheet, l&
    With Sheets("total_HP")
        .UsedRange.Offset(1).ClearContents
        For Each ws In Worksheets
             If Not ws.Name Like "total_HP" & "*" Then
                l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1
                ws.UsedRange.Offset(1).Copy .Range("a" & l)
            End If
        Next
    End With
End Sub

Sub Redesigner()[/P]
 Dim i As Long
    Dim hc As Integer, hr As Integer
    Dim ns As Worksheet
     
    hr = InputBox("1") 'wie viell titel
    hc = InputBox("3") 'wie viel kolonen mit text
         
    Application.ScreenUpdating = False
     
    i = 1
    Set inpdata = Selection
    Set ns = Worksheets.Add
     
    For r = (hr + 1) To inpdata.Rows.Count
        For c = (hc + 1) To inpdata.Columns.Count
            For j = 1 To hc
                ns.Cells(i, j) = inpdata.Cells(r, j)
            Next j
             
            For k = 1 To hr
                ns.Cells(i, j + k - 1) = inpdata.Cells(k, c)
            Next k
             
            ns.Cells(i, j + k - 1) = inpdata.Cells(r, c)
            i = i + 1
        Next c
    Next r
    
End Sub

Sub shCopy()   
    Dim BazaWb As Workbook      'файл для сбора данных   
Dim BazaSht As Worksheet    'лист в файле для сбора данных   
Dim SelectedItem As String  'имя файла выбранного в диалоге   
Dim oAwb As String          'имя открытой книги   

With Application   
        'отлючаем обновление экрана - это убыстрит работу макроса   
.ScreenUpdating = False   
        'включаем ручной пересчёт формул - это убыстрит работу макроса   
.Calculation = xlManual   
        'отключаем отображения окон на панели задач на время выполнения макроса   
.ShowWindowsInTaskbar = False   
        'присваиваем переменной BazaWb ссылку на общий файл   
Set BazaWb = ActiveWorkbook   


        'вызываем диалог выбора папки с файлами отчёта   
With Application.FileDialog(msoFileDialogFilePicker)   
            .Title = "Выберите файл для отчета"    'надпись в окне диалога   
'путь по умолчанию к папке /где расположен исходный файл   
.InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xls*"   
            .AllowMultiSelect = False    'запрет выбора нескольких файлов   
If .Show = False Then GoTo ErrExt:   
            'For Each SelectedItem In .SelectedItems 'перебор файлов в папке   
SelectedItem = .SelectedItems(1)    'при обработке нескольких - удалить   
oAwb = Dir(SelectedItem, vbDirectory)  'запоминаем имя книги   
Workbooks.OpenText SelectedItem         'открываем книгу   
'операции с открытой книгой   
With ActiveWorkbook   
                'перебор заданных листов   
.Sheets("SF1_lt").Copy before:=BazaWb.Sheets(1)   

            End With   

            Workbooks(oAwb).Close False    'закрываем книгу   
'Next SelectedItem   
        End With   
ErrExt:   
        'включаем автоматический пересчёт формул, который отключили в начале макроса   
.Calculation = xlAutomatic   
        'включаем отображения окон на панели задач, которое отключали в начали макроса   
.ShowWindowsInTaskbar = True   
        'включаем обновление экрана, который отключили в начале макроса   
.ScreenUpdating = True   
    End With   
End Sub