Sub get_all_title()
Dim sheet As Integer
Dim sheet_counter_start As Integer
Dim sheet_counter_end As Integer
Dim row_search As Integer
Dim title_search As Integer
Dim title_paste_start As Integer
Dim title_paste_next As Integer
Dim title_paste_end As Integer
Dim duplicates As Integer
Dim duplicates_start As Integer
Dim duplicates_end As Integer
Dim duplicates_search As Integer
Dim duplicates_counter As Integer
Dim duplicates_all As Integer
Dim commercial_finder As String
Dim num_finder As Integer
Dim copy_start As Integer
Dim copy_end As Integer
Dim copy_dif As Integer
Dim copy_max As Integer
Dim start_paste As Integer
Dim testarray
title_paste_start = 11
title_paste_next = title_paste_start
sheet_counter_start = 2
sheet_counter_end = Sheets.Count
For sheet = sheet_counter_start To sheet_counter_end
Sheets(sheet).Select
For row_search = 1 To 1000
If Cells(row_search, 1) = "No." Then
title_search = row_search - 1
If Cells(title_search, 1).Value = "Ersteinsätze" Or Cells(title_search, 1).Value = "Saalbezogen(gültigfüralleFilme)." Then
Else
Cells(title_search, 1).Select
Selection.Copy
Sheets(1).Select
Cells(title_paste_next, 1).Select
ActiveSheet.Paste
Sheets(sheet).Select
title_paste_next = title_paste_next + 1
title_paste_end = title_paste_next
End If
End If
Next row_search
Next sheet
Sheets(1).Select
duplicates_start = title_paste_start
duplicates_end = title_paste_end
duplicates_search_start = title_paste_start
duplicates_search_end = title_paste_end
For duplicates = duplicates_start To duplicates_end
For duplicates_search = duplicates_search_start To duplicates_search_end
If duplicates = duplicates_search Then
Else
If Cells(duplicates, 1) = Cells(duplicates_search, 1) And (Cells(duplicates_search, 1)) <> "" Then
Cells(duplicates_search, 1).Delete
duplicates_search = duplicates_search - 1
duplicates_end = duplicates_end - 1
duplicates_counter = duplicates_counter + 1
End If
End If
Next duplicates_search
Next duplicates
duplicates_end = duplicates_end - 1
duplicates_all = duplicates_end - duplicates_start + 1
MsgBox (duplicates_counter) & (" Duplikate gefunden/gelöscht")
Cells(title_paste_start, 1).Select
ActiveWorkbook.Worksheets("Analyse").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Analyse").Sort.SortFields.Add Key:=ActiveCell, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Analyse").Sort
.SetRange Range(Cells(title_paste_start, 1), Cells(duplicates_end, 1))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For duplicates = 11 To 1000
If IsEmpty(Cells(duplicates, 1)) Then
Else
Sheets(1).Select
commercial_finder = Cells(duplicates, 1).Value
copy_max = 0
For sheet = sheet_counter_start To sheet_counter_end
Sheets(sheet).Select
For row_search = 1 To 1000
If Cells(row_search, 1).Value = commercial_finder Then
num_finder = row_search
Do Until IsNumeric(Cells(num_finder, 1))
num_finder = num_finder + 1
Loop
copy_start = num_finder
Do While IsNumeric(Cells(num_finder, 1))
num_finder = num_finder + 1
If Cells(num_finder, 1) = "Presenter2D" Or Cells(num_finder, 1) = "Presenter3D" Then
num_finder = num_finder + 1
End If
Loop
num_finder = num_finder - 1
copy_end = num_finder
copy_dif = copy_end - copy_start + 1
MsgBox ("")
If copy_max < copy_dif Then
copy_max = copy_dif
End If
End If
Next row_search
Next sheet
Sheets(1).Select
For row_search = 11 To 1000
If Cells(row_search, 1).Value = commercial_finder Then
insert_row = row_search + 1
Cells(insert_row, 2).Select
MsgBox (copy_max)
For insert_rowx = 0 To copy_max
ActiveCell.EntireRow.Insert
Next insert_rowx
End If
Next row_search
MsgBox ("xx")
End If
Next duplicates
Sheets(1).Select
End Sub