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 nName As Name

For Each nName In ActiveWorkbook.Names
    nName.Delete
Next nName

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 tt2()
   Dim i As Integer
   Dim max As Integer
   Dim r As Integer
   Dim sl: Set sl = CreateObject("Scripting.Dictionary")
   max = WorksheetFunction.CountA(Sheets("Main").Columns(1))
   Randomize
   i = 1
   With Sheets("Main")
   Do
      r = Int(Rnd * max + 1)
      If Not sl.exists(r) Then
         .Cells(i, 2).Value = .Cells(r, 1)
         .Cells(i, 3).Value = r
         sl.Add r, 1
         i = i + 1
      End If
   Loop While sl.Count < 5
   End With
   'Set sl = Nothing

End Sub