Sub HorizontalSpiegeln()
For i = 1 To 20
    With Worksheets("buch 1")
        .Columns(i).Select
        Selection.Copy
        .Cells(1, 45 - i).Select
        .Paste
    End With
Next i
End Sub

Sub VertikalSpiegeln()
For i = 1 To 20
    With Worksheets("buch 1")
        .Rows(i).Select
        Selection.Copy
        .Cells(45 - i, 1).Select
        .Paste
    End With
Next i
End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Dim i As Integer
        Dim r As Integer
       
        If Target.Cells.Count > 1 Then Exit Sub
            ActiveSheet.Unprotect Password:=""

            If Not Intersect(Target, Range("C11:F11", "C12:F12")) Is Nothing Then
                r = Target.Row

                If Target = vbNullString Then
                    i = 0
                Else
                    i = 1
                End If

                Application.ScreenUpdating = False
                
                For Each Z In Range(Cells(r, 3), Cells(r, 6))
                    Z.Value = vbNullString
                Next
                
                Application.ScreenUpdating = True

                Target.Font.Name = "Wingdings 2"
                If i = 0 Then
                    Target = "Ð"
                Else
                    Target = vbNullString
                End If
            End If

             ActiveSheet.Protect Password:=""

Sub WordCreate()
    'On Error Resume Next

    Dim WordApp As Object
    Dim WordDoc As Object
    Dim ExcelTable As Range
    
    Dim i As Integer                       
    Dim Pos_Massnahme() As String          
    
    
    i = Sheets(ActiveSheet.Name).Cells(2, 2).Value
    
    
    Set ExcelTable = ThisWorkbook.Sheets("VD-LN").Range(Cells(8, 5), Cells(8 + i, 5))

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True 

    Set WordDoc = WordApp.Documents.Add

    ExcelTable.Copy
    WordApp.Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False

    Application.CutCopyMode = False

    Set WordDoc = Nothing
    Set WordApp = Nothing          
End Sub

HomeDir = ThisWorkbook.Path
file_Prefix_name = "/2023-09-28"
file_name = HomeDir & file_Prefix_name & " VD-TestFile.xlsx"

Worksheets(Array("1 One", "2 Two")).Copy
With ActiveWorkbook
    .SaveAs Filename:= file_name
    .Close SaveChanges:=False
End With

Worksheets(Array("1 One", "2 Two")).Copy

.SaveAs Filename:= file_name 

file_name = HomeDir & file_Prefix_name & " VD-TestFile.xlsx"

file_name = HomeDir & file_Prefix_name & " VD-Newton, Isaac [130552].xlsx"

Dim file_name As String

file_name = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & file_name, Destination:=Range("$A$4:$N$100"))
    .Name = "Vertragsansicht_1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = False
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 65001
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = True
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With

Sub aaa()
   Dim i As Integer
   Dim max As Integer
   Dim r As Integer

   max = WorksheetFunction.CountA(Sheets("Main").Columns(1))
   With Sheets("Main")
      For i = 1 To 5
         Randomize
         r = WorksheetFunction.Round(Rnd * (max - 1), 0) + 1
         .Cells(i, 2).Value = .Cells(r, 1)
         .Cells(i, 3).Value = r
      Next i
   End With
End Sub

    If l = 0 Then
        Msgbox De
        Msgbox Ru
    Else
        Msgbox Ru
        Msgbox De
    End If

    Sheets("Main").Cells(14 + i, 6).Value = De
    Sheets("Main").Cells(14 + i, 7).Value = "-"
    Sheets("Main").Cells(14 + i, 8).Value = Ru

    If l = 0 Then
        Msgbox De
        Sheets("Main").Cells(14 + i, 6).Value = De
        Sheets("Main").Cells(14 + i, 7).Value = "-"
        Msgbox Ru
        Sheets("Main").Cells(14 + i, 8).Value = Ru
    Else
        Msgbox Ru
        Sheets("Main").Cells(14 + i, 7).Value = "-"
        Sheets("Main").Cells(14 + i, 8).Value = Ru
        Msgbox De
        Sheets("Main").Cells(14 + i, 6).Value = De
    End If

MsgBox Sheets("Tabelle1").Cells(1, 1)

Public Function CellValue(ByVal ShName As String, ByVal Row As Integer, ByVal Col As Integer) As String
   CellValue = Sheets(ShName).Cells(Row, Col).Value
End Function

ДВВССЫЛ(СЦЕПИТЬ("'";ДВВССЫЛ(АДРЕС(СТРОКА();1));"'";"!";АДРЕС(5;3)))

ДВВССЫЛ("'"&[@№]&"'!C5")

=ГИПЕРССЫЛКА("["&Dienstblatt!$B$1&"]"&ДВССЫЛ(АДРЕС(ЯЧЕЙКА();1))&"!$A$1";"►")

=ЗНАЧЕН(ПСТР(ЯЧЕЙКА("filename";A1);ПОИСК("]";ЯЧЕЙКА("filename";A1))+1;65535))

=ГИПЕРССЫЛКА("["&Dienstblatt!$B$1&"]Main!"&АДРЕС(ПОИСКПОЗ(A1;Main!A:A;0);1);"◄")

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh Is Me.Sheets("Main") Or Sh Is Me.Sheets("Dienstblatt") Then Exit Sub
With Sh
    .Range("C1") = .Name
    .Hyperlinks.Add Anchor:=.Range("A1").Offset(i), Address:="", SubAddress:="Main!A1"
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

If Not Intersect(Target, Range("D7:D10")) Is Nothing Then
    If Target = vbNullString Then
        Target = "EU"
    Else
        Target = vbNullString
    End If
    
    Application.EnableEvents = False
    Cells(10, 21).Select                 ' после каждого клика я делаю активной постоянно одну и ту же ячейку 
    Application.EnableEvents = True
End If
End Sub

Sub GetID(sCol As String)
Dim iRow As Integer
Dim i As Integer
Dim j As Integer

iRow = Cells(65536, sCol).End(xlUp).Row

Application.ScreenUpdating = False

Range(sCol & "1:" & sCol & iRow).Offset(0, 9).ClearContents

For i = 1 To iRow
    If Range(sCol & i).Font.ColorIndex <> 1 Then
        For j = 1 To iRow
            If Range(sCol & i).Value = Range(sCol & j).Value Then
                If j <> i Then
                    Range(sCol & i).Offset(0, 9).Value = Range(sCol & i).Offset(0, 9).Value & ", " & j
                End If
            End If
        Next j
    End If
Next i

Application.ScreenUpdating = True

End Sub

For i = 0 To UBound(aFilter_TMP)
  aFilter_TMP(i) = Sheets("Form2").Range("I" & i + row_two%).Text
Next i

n = 0
For j = 0 To UBound(aFilter_TMP)
  If aFilter_TMP(j) <> 0 Then
    aFilter(n) = aFilter_TMP(j)
    n = n + 1
  End If
Next

If Not Intersect(Target, Range("I9, I10, I19, N19, S19, X10, X11, X12, X20")) Is Nothing Then
действие 1
End If
If Not Intersect(Target, Range("I12")) Is Nothing Then
действие 2
End If
If Not Intersect(Target, Range("D5")) Is Nothing Then
действие 3
End If
и т. д.

Select Case Target
      Case Range("I9"), Range("I10"), Range("I19"), Range("N19"), Range("S19"), Range("X10"), Range("X11"), Range("X12"), Range("X20")
             действие 1
      Case Range("I12")
             действие 2
      Case Range("D5")
             действие 3
      и т. д.
End Select

=ИНДЕКС(Source_Daten;ПОИСКПОЗ(Q6;Source_ID;0);1)

=100*R6/ПСТР(Q6;6;3)