Sub check_if_name_exist(name_of_sheet As String) ZEILEN_OFFSET = 4 For i = 1 To 300 w = i + ZEILEN_OFFSET temp = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & w).Value If temp = name_of_sheet Then gl_flagy = 100 End If Next i End Sub Sub fuege_eine_notiz_hinzu_2() Dim aktuelle_zeile As Integer Dim name_neues_blatt As String Dim var1 As String Dim ebenen(1 To 300) As Integer Dim ebene_ As Integer 'dim globaL_deb1 as integer globaL_deb1 = 1 ' zeile einlesen (ebene) ZEILEN_OFFSET = 4 For i = 1 To 300 w = i + ZEILEN_OFFSET ebenen(i) = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & w).Value Next i ' cursor aktuelle_zeile = ActiveCell.Row var1 = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & aktuelle_zeile).Value selce_at_the_end = "B" & CStr(aktuelle_zeile + 1) var2 = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & aktuelle_zeile).Value name_neues_blatt = Application.InputBox("Name neues Blatt...", Default:="?", Type:=2) '716 gl_forbidden = 0 Call check_len(name_neues_blatt) If gl_forbidden = 1 Then MsgBox "der name des tabellenblattes ist zu lang!" flag = 10 gl_forbidden = 0 End If gl_flagy = 0 Call check_if_name_exist(name_neues_blatt) If gl_flagy = 100 Then MsgBox "der name des blattes existiert bereits" flag = 10 gl_flagy = 0 End If gl_flagy = 0 ruekgabewert = InStrRev(name_neues_blatt, " ", , vbTextCompare) 'zwischen_var = array_speichert_tabellen_blatter(zaehler_tabellenblaetter) If (ruekgabewert > 0) Then flag = 10 MsgBox "bitte ohne leerzeichen und sonderzeichen!!" End If If flag <> 10 Then ebene_ = Application.InputBox("Ebene neues Blatt...", Default:=var2, Type:=1) ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & (aktuelle_zeile + 1)).Value = ebene_ 'MsgBox var1 ''' Sheets("Inhaltsverzeichnis").Select Sheets.Add After:=ActiveSheet ActiveSheet.Name = name_neues_blatt Range("A1").Select Sheets("Inhaltsverzeichnis").Select 'Call schreibe_inhaltsverzeichnis_2 Sheets(name_neues_blatt).Select ' Inhaltsverzeichnis Sheets("Inhaltsverzeichnis").Select ' Inhaltsverzeichnis Call move_it(name_neues_blatt, var1) Sheets("Inhaltsverzeichnis").Select ' Inhaltsverzeichnis Call schreibe_inhaltsverzeichnis_2 Sheets("Inhaltsverzeichnis").Select ' Inhaltsverzeichnis Range("A1").Select ' zeile schreiben (ebene) h = 1 w = 1 + ZEILEN_OFFSET ZEILEN_OFFSET = 4 t_ = aktuelle_zeile - ZEILEN_OFFSET 'MsgBox t_ For i = (1) To 300 textvar = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & (w)).Value If textvar = "" Then Else ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & (w)).Value = ebenen(h) End If If i = (t_) Then w = i + ZEILEN_OFFSET + 2 h = h Else w = i + (ZEILEN_OFFSET + 1) h = h + 1 End If Next i Call rest_farbe Call inhaltsverzeichnis_einfaerben 'Range("A1").Select 'selce_at_the_end Range(selce_at_the_end).Select 'selce_at_the_end End If globaL_deb1 = 0 Call alles_einblenden_wiki Range(selce_at_the_end).Select 'selce_at_the_end End Sub Sub res() 'dim globaL_deb1 as integer globaL_deb1 = 1 Call rest_farbe Call inhaltsverzeichnis_einfaerben Call schreibe_inhaltsverzeichnis_2 Range("A1").Select 'dim globaL_deb1 as integer globaL_deb1 = 0 End Sub Sub add_history() '560 str n str+n str_n Dim aktueller_name As String aktueller_name = CStr(ActiveSheet.Name) Call schreibe_historie ActiveWorkbook.Worksheets("historie").Range("H5").Value = aktueller_name End Sub Sub jump_history() '560 str m str+m str_m Sheets("historie").Select End Sub Sub rejump_history() '560 str h str+h str_h Dim aktueller_name As String aktueller_name = ActiveWorkbook.Worksheets("historie").Range("H5").Value Sheets(aktueller_name).Select End Sub Sub check_len(MyString As String) 'MyString = "abc" MyLen = Len(MyString) 'MsgBox MyLen If MyLen > 31 Then gl_forbidden = 1 End If ' Returns 3 - 3 characters in the strin End Sub Sub rename_it() 'str_y Dim nam As String Dim neuer_wert As String neuer_wert = Application.InputBox("new name:", Default:=1, Type:=2) ' 1: ganzzahl 2: string zeil = ActiveCell.Row nam = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & zeil).Value 'MsgBox nam 'Sheets("Inhaltsverzeichnis").Select Sheets(nam).Select 'Sheets("3036").Select ActiveSheet.Name = neuer_wert Sheets("Inhaltsverzeichnis").Select Call res End Sub Sub springe_zu_inhaltsverzeichnis_2() 'str_y Sheets("Inhaltsverzeichnis").Select End Sub Sub schreibe_inhaltsverzeichnis_2_FALSCH() Dim zaehler_tabellenblaetter As Integer Dim array_speichert_tabellen_blatter(1 To 300) As String Dim array_speichert_tabellen_blatter_namen(1 To 300) As String Dim zeile As Integer Dim ZEILEN_OFFSET As Integer flag = 0 '----------------------------------------- ' Parmter setzen ARBEITS_SPALTE = "B" ZEILEN_OFFSET = 4 '----------------------------------------- Columns(ARBEITS_SPALTE & ":" & ARBEITS_SPALTE).Select Selection.ClearContents zaehler_tabellenblaetter = 1 Dim WsTabelle As Worksheet For Each WsTabelle In Sheets With WsTabelle array_speichert_tabellen_blatter(zaehler_tabellenblaetter) = WsTabelle.Name array_speichert_tabellen_blatter_namen(zaehler_tabellenblaetter) = WsTabelle.Name so_heiis_das_blatt = array_speichert_tabellen_blatter(zaehler_tabellenblaetter) ruekgabewert = InStrRev(so_heiis_das_blatt, " ", , vbTextCompare) 'zwischen_var = array_speichert_tabellen_blatter(zaehler_tabellenblaetter) If (ruekgabewert > 0) Then so_heiis_das_blatt_neu = "'" & so_heiis_das_blatt & "'" flag = 1 'MsgBox so_heiis_das_blatt_neu array_speichert_tabellen_blatter(zaehler_tabellenblaetter) = so_heiis_das_blatt_neu array_speichert_tabellen_blatter_namen(zaehler_tabellenblaetter) = so_heiis_das_blatt End If End With zaehler_tabellenblaetter = zaehler_tabellenblaetter + 1 Next WsTabelle For i = 1 To (zaehler_tabellenblaetter - 1) Step 1 zeile = i + ZEILEN_OFFSET Range(ARBEITS_SPALTE & zeile).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ array_speichert_tabellen_blatter(i) & "!A1", TextToDisplay:=array_speichert_tabellen_blatter_namen(i) Next i End Sub Sub schreibe_inhaltsverzeichnis_2() Dim zaehler_tabellenblaetter As Integer Dim array_speichert_tabellen_blatter(1 To 300) As String Dim zeile As Integer Dim ZEILEN_OFFSET As Integer '----------------------------------------- ' Parmter setzen ARBEITS_SPALTE = "B" ZEILEN_OFFSET = 4 '----------------------------------------- Columns(ARBEITS_SPALTE & ":" & ARBEITS_SPALTE).Select Selection.ClearContents zaehler_tabellenblaetter = 1 Dim WsTabelle As Worksheet For Each WsTabelle In Sheets With WsTabelle array_speichert_tabellen_blatter(zaehler_tabellenblaetter) = WsTabelle.Name 'ruekgabewert = InStrRev(array_speichert_tabellen_blatter(zaehler_tabellenblaetter), " ", , vbTextCompare) 'zwischen_var = array_speichert_tabellen_blatter(zaehler_tabellenblaetter) 'If (ruekgabewert > 0) Then ' array_speichert_tabellen_blatter(zaehler_tabellenblaetter) = "'" & array_speichert_tabellen_blatter(zaehler_tabellenblaetter) & "'" 'End If End With zaehler_tabellenblaetter = zaehler_tabellenblaetter + 1 Next WsTabelle For i = 1 To (zaehler_tabellenblaetter - 1) Step 1 zeile = i + ZEILEN_OFFSET Range(ARBEITS_SPALTE & zeile).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ array_speichert_tabellen_blatter(i) & "!A1", TextToDisplay:=array_speichert_tabellen_blatter(i) Next i End Sub Sub test_makro() Call move_it("meeting", "einkaufszettel") End Sub Sub move_it(nehme_das_blatt As String, schiebe_hinter_das_blatt As String) 'Sheets("hallo").Move Before:=Sheets("meeting") ' schiebe_hinter_das_blatt Sheets(nehme_das_blatt).Select so_heiis_das_blatt = schiebe_hinter_das_blatt so_heiis_das_blatt_neu = schiebe_hinter_das_blatt 'ruekgabewert = InStrRev(so_heiis_das_blatt, " ", , vbTextCompare) 'If (ruekgabewert > 0) Then 'so_heiis_das_blatt_neu = "'" & so_heiis_das_blatt & "'" 'End If ActiveSheet.Move After:=Sheets(schiebe_hinter_das_blatt) '516 End Sub Sub inhaltsverzeichnis_einfaerben() Dim gelb As String Dim w As Integer 'Call wiki_farben_setzen(24, "gruen") ZEILEN_OFFSET = 4 For i = 1 To 300 w = i + ZEILEN_OFFSET test_var = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & w).Value If test_var = 1 Then Call wiki_farben_setzen(w, "gruen") ElseIf test_var = 2 Then Call wiki_farben_setzen(w, "gelb") ElseIf test_var = 3 Then Call wiki_farben_setzen(w, "rot") End If test_var2 = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & w).Value If test_var2 = "Inhaltsverzeichnis" Or test_var2 = "quellen" Or test_var2 = "ordner" Or test_var2 = "url" Or test_var2 = "historie" Or test_var2 = "todo" Then Call wiki_farben_setzen(w, "blau") End If Next i End Sub Sub rest_farbe() ' erst_mal_die_farbe_wieder_auf_weiss Makro Range("B5:C100").Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Range("A1").Select End Sub Sub wiki_farben_setzen2222(zeile As Integer, farbe As String) If farbe = "rot" Then color_akz = xlThemeColorAccent2 ElseIf farbe = "blau" Then color_akz = xlThemeColorAccent5 ElseIf farbe = "gruen" Then color_akz = xlThemeColorAccent6 ElseIf farbe = "gelb" Then 'color_akz = xlThemeColorAccent4 color_akz = 65535 ElseIf farbe = "blau" Then color_akz = xlThemeColorAccent5 End If Range("B" & zeile & ":C" & zeile).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = color_akz .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With End Sub Sub wiki_farben_setzen(zeile As Integer, farbe As String) If farbe = "rot" Then color_akz = 49407 ElseIf farbe = "gruen" Then color_akz = 5296274 ElseIf farbe = "gelb" Then 'color_akz = xlThemeColorAccent4 color_akz = 65535 ElseIf farbe = "blau" Then color_akz = 15773696 End If Range("B" & zeile & ":C" & zeile).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = color_akz .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub Sub Makro3() ' ' Makro3 Makro ' ' Range("B107:C107").Select Range("C107").Activate With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub Sub alles_einblenden_wiki() Rows("5:500").Select Selection.EntireRow.Hidden = False Range("A1").Select End Sub Sub ebene_1() Dim zw_var As Integer Call alles_einblenden_wiki For k = 1 To 300 Step 1 e = k + 4 'zw_var = ActiveWorkboook.Worksheets("Inhaltsverzeichnis").Range("C" & CStr(e)).Value zw_var = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & CStr(e)).Value If zw_var = 2 Then Rows(e & ":" & e).Select Selection.EntireRow.Hidden = True End If If zw_var = 3 Then Rows(e & ":" & e).Select Selection.EntireRow.Hidden = True End If Next k End Sub Sub ebene_2() Call alles_einblenden_wiki For k = 1 To 300 Step 1 e = k + 4 zw_var = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & CStr(e)).Value If zw_var = 3 Then Rows(e & ":" & e).Select Selection.EntireRow.Hidden = True End If Next k End Sub Sub ebene_3() Call alles_einblenden_wiki End Sub Sub str_w_makrouebesicht_oeffnen() ' old str + w str_w str w Dim ssstring As String ssstring = "Bitte Skript wählen" _ & Chr(13) _ & Chr(13) _ & Chr(13) _ & Chr(13) _ & "1: Link" _ & Chr(13) _ & Chr(13) _ & "2: new lines " _ & Chr(13) _ & Chr(13) _ & "3: LEER" _ & Chr(13) _ & Chr(13) _ & "4: neuer Abschnitt" _ & Chr(13) _ & Chr(13) _ & "5: A1" _ & Chr(13) _ & Chr(13) _ & "6: Inahlt fixieren" _ & Chr(13) _ & Chr(13) _ & "7: rückgangig fixierung" & Chr(13) & Chr(13) & "8: blatt einfaerben" & Chr(13) & Chr(13) & "9: textbox adden" & Chr(13) & Chr(13) & "10: Pfeil einfügen" & Chr(13) & Chr(13) & "11: Springe zu Tabellenblatt" & Chr(13) & Chr(13) & "12: Drucke aktuelle Seite" & Chr(13) & Chr(13) & "13: ordne-rnummer" & Chr(13) & Chr(13) & "14: quellen-nnummer" & Chr(13) & Chr(13) & "15: url-nummer" & Chr(13) & Chr(13) & "16: todo-formatierung in Spalte B" & Chr(13) & Chr(13) & "17: schreibe historie" & Chr(13) & Chr(13) & "18: schreibe text-datei" ' schreibe_historie 'default_val = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("H3").Value default_val = 1 Message = ssstring Title = "InputBox" Default1 = default_val sNummer = InputBox(Message, Title, Default1) iNummer = CInt(sNummer) If iNummer = 1 Then Call create__link ElseIf iNummer = 2 Then Call neww__lines ElseIf iNummer = 3 Then 'Call jump___ ' zz99a_ccc_springe_zu_tabblatt ElseIf iNummer = 4 Then Call neuer_abschnitt 'Call zz71a_aaa20_textboxEinfügen ElseIf iNummer = 5 Then Call springe_A1 'Call zz71a_aaa20_pfeileinfuegen ElseIf iNummer = 6 Then Call fenster_fixieren 'Call zz99a_aaa14_newAbschnitt ElseIf iNummer = 7 Then Call reset_fixierung 'Call zz71a_aaa15ZellenEinfügen ElseIf iNummer = 8 Then Call blatt_faerben 'Call zz99a_go_to_A1 ElseIf iNummer = 9 Then Call textboxEinfügen 'Call zz16_UniversalFilter ElseIf iNummer = 10 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call pfeileinfuegen ElseIf iNummer = 11 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call SpringeZuTabblatt_durch_texteingabe ElseIf iNummer = 12 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call drucke_jetzt ' ONE_PAGEdina3FormatUndAllesAufEineSeiteDrucken ElseIf iNummer = 13 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call ordnernummer ElseIf iNummer = 14 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call quellennummer ElseIf iNummer = 15 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call urlnummer ElseIf iNummer = 16 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call todo_formatierung ElseIf iNummer = 17 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call schreibe_historie ElseIf iNummer = 18 Then 'Call zz99a_ccE_CLEAR_filter_spezial SpringeZuTabblatt_durch_texteingabe Call schreibe_text_datei3333 Else ' todo_formatierung End If End Sub Sub create__link() Dim folder_number As String Dim Textt As String Dim MyValue2 As String Dim Default As String Message2 = "on sheet...." MyValue = InputBox(Message2, Title, Default) 'Textt = InputBox(Message2, Title, Default) Message2 = "on cell....." Default = "A1" MyValue2 = InputBox(Message2, Title, Default) Textt = Selection.Address zuuuuu = "Internal_Link: " & MyValue Range(Textt).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ MyValue & "!" & MyValue2, TextToDisplay:=zuuuuu Call add_history End Sub Sub neww__lines() setzevaufacht = 8 akt_zeile = ActiveCell.Row For i = 1 To 10 Rows(akt_zeile & ":" & akt_zeile).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Next i Call neuer_abschnitt setzevaufacht = 0 End Sub Sub ddd() setzevaufacht = 0 End Sub Sub Makro6() ' With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 '750 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With ' ' Rows("28:28").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With End Sub ' beschreibung: str+0 fügt neuieuen abschnitt auf tabblatt ein, curso muss in spalte A sein Sub neuer_abschnitt() ' neuer abschnitt hinzufüfen a14_newAbschnitt ' achtung 2000 muss geändert werdden falls länger Dim MyValue_offset As Integer Dim MyValue_offset_string As String Dim offset_xxx As Integer Dim MyValue As String Dim aStrings(1 To 100) As String Dim aZeilen(1 To 100) As Integer Dim letztezeile As Integer Dim aktueller_name As String Dim sddddateiName As String offset_xxx = 15 ' --------------------------------------------------------------------------------------------------------------------------------------------------- 'sddddateiName = Tabelle17.Range("H1").Value aktueller_name = CStr(ActiveSheet.Name) ' aktueller_Name: aktueller Name des Tabellenblattes MyValue = ActiveCell.Row ' MyValue: nummer der aktiven zeile MyValue_offset = CInt(MyValue) + 20 MyValue_offset_string = CStr(MyValue_offset) If setzevaufacht <> 8 Then Rows(MyValue & ":" & MyValue).Select ' formatierung With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With ActiveWorkbook.Worksheets(aktueller_name).Range("P" & MyValue).Value = Format(Now, "YYYY" & " " & "MM" & " " & "DD" & " ||| " & "hh" & ":" & "mm") ' ------------------------------------------------------------ name des kapitels angeben Dim Message, Title, Default, MyValue2 As String Message = "Name des Kapitels " ' Set prompt. Title = "InputBox" ' Set title. Default = "name" ' Set default. ' Display message, title, and default value. MyValue2 = InputBox(Message, Title, Default) ' ------------------------------------------------------------ ' ------------------------------------------------------------ die zeile korrekt benamen Range("A" & MyValue).Select ActiveCell.FormulaR1C1 = "kapitel >>> " & MyValue2 'Range("A29").Select End If b = 0 j = 1 For i = 3 To 2000 Step 1 ' ---------------------------------------------------------- von 3 bis 100 wegen A3 (inhalt:) aStrings(j) = "leer" ' ---------------------------------------------------------- erst mal in jeden string das wort leer schreiben bei 3 angefangen m = ActiveWorkbook.Worksheets(aktueller_name).Range("A" & i).Value ' das was in der aktiven zelle steht in m schreiben If (m <> "") Then ' wenn m nicht leer ist, dann schreibe ich in den string, das was in der zelle steht w = i - b If b < 10 Then aStrings(j) = "[0" & b & "] " & ActiveWorkbook.Worksheets(aktueller_name).Range("A" & i).Value ' siehe kommenta eine zeile weiter oben End If If b >= 10 Then aStrings(j) = "[" & b & "] " & ActiveWorkbook.Worksheets(aktueller_name).Range("A" & i).Value ' siehe kommenta eine zeile weiter oben End If aZeilen(j) = i letztezeile = i j = j + 1 ' zähler b = b + 1 'MsgBox (speichere) End If Next i j = j - 2 einlesen = ActiveWorkbook.Worksheets(aktueller_name).Range("A3").Value ' einlesen was in zelle a3 steht: Nur wenn inhalt: dann geht es weiter ' nur wenn in zelle A3 inhalt: steht wird das inhaltsverzeichnis geschrieben If (einlesen = "inhalt:") Then ' alles alte erst mal löschen : start Range("B3").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents ' alles alte erst mal löschen : ende Range("A3").Select k = 0 For i = 4 To 2000 Step 1 ' zählen wieviel platzt unterhalb A3 m = ActiveWorkbook.Worksheets(aktueller_name).Range("A" & i).Value k = k + 1 If (m <> "") Then Exit For ' wenn die erste zelle kommt in der was drin steht aufhören mit dem zählen 'MsgBox (speichere) End If Next i k = k - 1 ' k zählt also wieviele zellen man noch platz hat um inhaltsangabe zu schreiben 'k = k - 1 If k >= j Then w = 2 For i = 2 To (j + 1) Step 1 ' bei 2 anfangen wegen inhalt: w = w + 1 ActiveWorkbook.Worksheets(aktueller_name).Range("B" & w).Value = aStrings(i) ' hier schreibe ich den namen Range("B" & w).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ aktueller_name & "!A" & CStr(aZeilen(i) + offset_xxx), TextToDisplay:=aStrings(i) Next i Else MsgBox "zu wenig freie zellen, bitte zellen für inhaltsangabe einfügen " End If Range("A" & letztezeile).Select End If Range("A" & MyValue).Select End Sub Sub springe_A1() Range("A12").Select Range("A1").Select End Sub Sub fenster_fixieren() Rows("2:2").Select Range("A2").Activate Selection.EntireRow.Hidden = True zeilen_die_fixiert_werden_sollen = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F4").Value zeilen_die_fixiert_werden_sollen_plus_1 = zeilen_die_fixiert_werden_sollen + 1 Rows(zeilen_die_fixiert_werden_sollen_plus_1 & ":" & zeilen_die_fixiert_werden_sollen_plus_1).Select ActiveWindow.FreezePanes = True ActiveWindow.SmallScroll Down:=0 Rows("1:" & zeilen_die_fixiert_werden_sollen).Select Range("A" & zeilen_die_fixiert_werden_sollen).Activate With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With Range("A3").Select End Sub Sub blatt_faerben() ' blau orange grün str w str+w Dim akt_nam As String Dim farbauswahl As String Dim farbentscheidung As String 'farbauswahl = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F3").Value farbauswahl = "blau" 'fixieren = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F4").Value fixieren = "ja" Cells.Select If farbauswahl = "blau" Then farbentscheidung = xlThemeColorAccent1 ElseIf farbauswahl = "orange" Then farbentscheidung = xlThemeColorAccent2 ElseIf farbauswahl = "gruen" Then farbentscheidung = xlThemeColorAccent6 End If With Selection.Interior .PatternColorIndex = xlAutomatic .ThemeColor = farbentscheidung .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With If fixieren = "ja" Then Call fenster_fixieren End If Range("A1").Select akt_nam = ActiveSheet.Name ActiveWorkbook.Worksheets(akt_nam).Range("A3").Value = "inhalt:" 'Call hole_button(akt_nam) Call hole_button_neu(akt_nam) End Sub Sub hole_button_neu(name_blatt As String) ' ' Makro12 Makro ' ' ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 Sheets("Inhaltsverzeichnis").Select Range("AQ1").Select ActiveSheet.Shapes.Range(Array("Picture 29")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31")). _ Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5", "Picture 23")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5", "Picture 23", "Picture 22")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5", "Picture 23", "Picture 22", _ "Picture 27")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5", "Picture 23", "Picture 22", _ "Picture 27", "Picture 12")).Select ActiveSheet.Shapes.Range(Array("Picture 29", "Picture 32", "Picture 31", _ "Picture 28", "Picture 4", "Picture 26", "Picture 21", "Picture 30", _ "Picture 6", "Picture 24", "Picture 5", "Picture 23", "Picture 22", _ "Picture 27", "Picture 12", "Picture 18")).Select Selection.Copy ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 Sheets(name_blatt).Select Range("F2").Select newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 4 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime ActiveSheet.Paste Selection.ShapeRange.IncrementLeft 209.25 Selection.ShapeRange.IncrementTop 1.5 Range("A1").Select ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 Sheets("Inhaltsverzeichnis").Select Range("B4").Select ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 Sheets(name_blatt).Select Range("A1").Select End Sub Sub hole_button(bl As String) ' ' Makro8 Makro ' ' ActiveWindow.ScrollWorkbookTabs Sheets:=-1 ActiveWindow.ScrollWorkbookTabs Sheets:=-1 Sheets("Inhaltsverzeichnis").Select ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 3 ActiveWindow.ScrollColumn = 4 ActiveWindow.ScrollColumn = 18 ActiveWindow.ScrollColumn = 19 ActiveWindow.ScrollColumn = 20 ActiveWindow.ScrollColumn = 21 ActiveWindow.ScrollColumn = 22 ActiveWindow.ScrollColumn = 23 Range("Z3").Select ActiveSheet.Shapes.Range(Array("Picture 12")).Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4")).Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4", "Picture 5")). _ Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4", "Picture 5", _ "Picture 6")).Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4", "Picture 5", _ "Picture 6", "Picture 18")).Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4", "Picture 5", _ "Picture 6", "Picture 18", "Picture 21")).Select ActiveSheet.Shapes.Range(Array("Picture 12", "Picture 4", "Picture 5", _ "Picture 6", "Picture 18", "Picture 21", "Picture 22")).Select Selection.Copy ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 ActiveWindow.ScrollWorkbookTabs Sheets:=1 Sheets(bl).Select Range("F14").Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -35.25 Selection.ShapeRange.IncrementTop -119.25 End Sub Sub hole_button2(bl As String) ' ' Makro3 Makro ' ' Sheets("Inhaltsverzeichnis").Select 'chapter ActiveSheet.Shapes.Range(Array("Picture 12")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'new lines ActiveSheet.Shapes.Range(Array("Picture 4")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'text box ActiveSheet.Shapes.Range(Array("Picture 5")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'pfeil ActiveSheet.Shapes.Range(Array("Picture 6")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'search ActiveSheet.Shapes.Range(Array("Picture 18")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'print pdf ActiveSheet.Shapes.Range(Array("Picture 21")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste 'print txt ActiveSheet.Shapes.Range(Array("Picture 22")).Select Selection.Copy Sheets(bl).Select Range("J1").Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft 23.25 Selection.ShapeRange.IncrementTop 12.75 End Sub Sub reset_fixierung() ' ' Makro6 Makro ' ' Rows("2:12").Select Range("A12").Activate ActiveWindow.FreezePanes = False Range("A3").Select End Sub Sub textboxEinfügen() Dim aktueller_Name2222 As String Dim i As Integer Dim speichere As Integer Dim m As String Dim savename As String Dim aktueller_name As String Dim name__ As String Dim nametabblatt As String Dim MyValueInt As Integer aktueller_Name2222 = CStr(ActiveSheet.Name) MyValueInt = ActiveCell.Row Dim Message, Title, Default, MyValue333 As String Message = "Kapitel angeben: " ' Set prompt. Title = "InputBox" ' Set title. Default = "keine Angabe" ' Set default. MyValue = ActiveCell.Address Range(MyValue).Select ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 60, 114, 350, _ 86.25).Select dVerschieben = ((CDbl(MyValueInt) - 7) / 10) * 130 Selection.ShapeRange.IncrementTop dVerschieben End Sub Sub pfeileinfuegen() Dim aktueller_Name2222 As String Dim i As Integer Dim speichere As Integer Dim m As String Dim savename As String Dim aktueller_name As String Dim name__ As String Dim nametabblatt As String Dim MyValueInt As Integer aktueller_Name2222 = CStr(ActiveSheet.Name) MyValueInt = ActiveCell.Row Dim Message, Title, Default, MyValue333 As String Message = "Kapitel angeben: " ' Set prompt. Title = "InputBox" ' Set title. Default = "keine Angabe" ' Set default. MyValue = ActiveCell.Address Range(MyValue).Select ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 60, 114, 350, _ 86.25).Select Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle dVerschieben = ((CDbl(MyValueInt) - 7) / 10) * 130 Selection.ShapeRange.IncrementTop dVerschieben End Sub Sub SpringeZuTabblatt_durch_texteingabe() 'str d Dim m As String Dim ke As String Dim str As String Dim e As Integer Dim tmp As String Dim skkip_it As Integer Dim var_aaa As String Call add_history skkip_it = 0 var_aaa = "aaa" Dim Message, Title, Default, MyValue333, MyValue444 As String Dim sddddateiName As String Message = "Springe zu ...." ' Set prompt. Title = "InputBox" ' Set title. Default = "historie" ' Set default. ' Display message, title, and default value. MyValue444 = InputBox(Message, Title, Default) e = InStrRev(MyValue444, var_aaa, , vbTextCompare) If (e > 0) Then 'Exit For skkip_it = 1 tmp = Right(MyValue444, Len(MyValue444) - 3) ke = tmp Sheets(ke).Select 'MsgBox (speichere) End If 'Sheets(ke).Select If skkip_it = 0 Then 'Sheets(MyValue444).Select Sheets("Inhaltsverzeichnis").Select For i = 5 To 300 Step 1 m = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & i).Value e = InStrRev(m, MyValue444, , vbTextCompare) If (e > 0) Then 'Exit For speichere = i ke = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & i).Value 'MsgBox (speichere) End If Next i 'MsgBox ke If ke = "" Then MsgBox "diese Seite wurde leider nicht gefunden!" Else Sheets(ke).Select End If 'Call check_if_name_exist(ke) 'MsgBox gl_flagy 'If gl_flagy = 100 Then ' Sheets(ke).Select ' gl_flagy = 0 'Else ' MsgBox "diese Seite wurde leider nicht gefunden!" 'End If 'End If End If '430 'Call add_history End Sub Sub pdf_der_ganzen_mappe_drucken() Call einblenden__ Call schreibe_seiten_zahlen Call dina3FormatUndAllesAufEineSeiteDrucken Dim aktueller_name As String 'aktueller_name = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis aktueller_name = Verzeichnis ChDir aktueller_name ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ aktueller_name & "\wiki.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, Openafterpublish:= _ True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = 215 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With 'Application.PrintCommunication = True ' auskommentiert56 Range("E14").Select ActiveWorkbook.Save Call loesche_seiten_zahlen End Sub Sub dina3FormatUndAllesAufEineSeiteDrucken() Dim AnzahlTabBlaetter As Integer AnzahlTabBlaetter = ActiveWorkbook.Sheets.Count Dim schreibe_seite As String For i = 1 To AnzahlTabBlaetter Step 1 Sheets(i).Select name_tab = ActiveSheet.Name If i > 1 Then schreibe_seite = "Seite: " & CStr(i) & " " & name_tab 'ActiveWorkboook.Worksheets(name_tab).Range("A1").Value = schreibe_seite ActiveWorkbook.Worksheets(name_tab).Range("A1").Value = schreibe_seite End If ' ' din_a4 Makro ' ' Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 0 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA5 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Range("E12").Select Next i Sheets("Inhaltsverzeichnis").Select End Sub Sub einblenden__() Rows("1:500").Select Selection.EntireRow.Hidden = False Range("A1").Select End Sub Sub schreibe_seiten_zahlen() Dim zwischenvariable As String Dim offset As Integer Dim aktuelle_zeile As Integer offset = 4 For i = 1 To 300 Step 1 aktuelle_zeile = i + offset wert = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & aktuelle_zeile).Value seitenzahl = "Seite: " & CStr(i) If wert = "" Then Else ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("A" & aktuelle_zeile).Value = seitenzahl End If Next i End Sub Sub loesche_seiten_zahlen() Dim zwischenvariable As String Dim offset As Integer Dim aktuelle_zeile As Integer offset = 4 For i = 1 To 300 Step 1 aktuelle_zeile = i + offset wert = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & aktuelle_zeile).Value If wert = "" Then Else ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("A" & aktuelle_zeile).Value = "" End If Next i End Sub Sub drucke_jetzt() Dim name_des_blattes As String Dim so_soll_es_heissen As String Call ONE_PAGEdina3FormatUndAllesAufEineSeiteDrucken name_des_blattes = ActiveSheet.Name so_soll_es_heissen = ActiveSheet.Name Call blatt____drucken(name_des_blattes, so_soll_es_heissen) End Sub Sub blatt____drucken(blatt As String, name_of_document As String) 'dominik Dim sVar As String Dim sVar4 As String Dim sDok As String Dim sheetname As String Dim Verzeichnis As String Sheets(blatt).Select sheetname = ActiveSheet.Name Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis 'ActiveWorkbook.Worksheets("Input").Range("C4").Value = Verzeichnis 'sVar = ActiveWorkbook.Worksheets("InputMaske").Range("N2").Value 'sVar4 = sVar & "\pdf-data-losses\" Worksheets(sheetname).Activate sDok = name_of_document ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ Verzeichnis & "\" & name_of_document & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ Openafterpublish:=True End Sub Sub Alle_Quellen_einlesen() Dim links_zu_dokumenten(1 To 2000) As String Dim links_zu_my(1 To 2000) As String Dim links_zu_foldern(1 To 2000) As String Dim aktueller_name As String Dim ofs As Integer Dim m As Integer Dim sddddateiName As String '------------------------------------------------------------m1 die spalten B auf tabblatt f m und fi löschen aktueller_name = CStr(ActiveSheet.Name) Sheets("quellen").Select 'Range("B38:B10000").Select 'Selection.ClearContents 'Call zz99a_reset_filter_files Sheets("quellen").Select ' register_files files ' erstes makro Dim lngZeile As Long Dim objFileSystem As Object Dim objVerzeichnis As Object Dim objDateienliste As Object Dim objDatei As Object Dim letztezeile As Integer ' 'zweites makro 'Sheets("Folder").Select Dim objFSO As Object Dim objFolder As Object Dim strPfad As String Dim objSubfolder As Object, colSubfolders As Object Dim i As Integer ' -------------------------------------------------------------------------------------------------------------------- fetch quellen Dim sVerzeichnis1 As String Dim sVerzeichnis2 As String Dim sVerzeichnis3 As String Dim TabBlatt_dateien As String Dim TabBlatt_ordner As String Dim bool_var As Integer Verzeichnis = ActiveWorkbook.Path 'marke12 Verzeichnis = Verzeichnis & "\quellen" ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis sVerzeichnisA = ActiveWorkbook.Worksheets("quellen").Range("B2").Value ' Files If sVerzeichnisA = "" Then sVerzeichnis1 = Verzeichnis Else sVerzeichnis1 = sVerzeichnisA End If 'MsgBox sVerzeichnis1 ' ----------------------------------------------------------------------------------------------------------------------- ' erstes makro zum schreiben der dokumentennamen m2 - schreibe dokumenten name auf fi Sheets("quellen").Select '----------------------------- name tab blatt Range("C3").Select ' Columns("B:B").Select ' ----------------------- hier A 1 B 2 ' Selection.ClearContents Set objFileSystem = CreateObject("scripting.FileSystemObject") Set objVerzeichnis = objFileSystem.GetFolder(sVerzeichnis1) Set objDateienliste = objVerzeichnis.Files lngZeile = 1 ofs = 20 '---------------------------------------------------------------------------- mar5_10 u = 1 ' hier For Each objDatei In objDateienliste m = u + ofs If Not objDatei Is Nothing Then 'ActiveSheet.Cells(lngZeile, 1) = objDatei.Name lngZeile = lngZeile + 1 Range("B" & m).Select ' m links_zu_dokumenten(u) = sVerzeichnis1 & "\" & objDatei.Name ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sVerzeichnis1 & "\" & objDatei.Name, _ TextToDisplay:=objDatei.Name ActiveWorkbook.Worksheets("quellen").Range("G" & m).Value = sVerzeichnis1 & "\" & objDatei.Name ' neu neu u = u + 1 End If Next objDatei letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row letztezeile = letztezeile + 1 Range("C1").Select Range("A1").Select End Sub Sub Alle_Ordner_holen() Dim links_zu_dokumenten(1 To 2000) As String ' QUELLEN HOLLEN Dim links_zu_my(1 To 2000) As String Dim links_zu_foldern(1 To 2000) As String Dim aktueller_name As String Dim ofs As Integer Dim m As Integer Dim sddddateiName As String aktueller_name = CStr(ActiveSheet.Name) Sheets("ordner").Select Range("C38:C10000").Select Selection.ClearContents Sheets("ordner").Select Range("C38:C10000").Select Selection.ClearContents Sheets("ordner").Select Dim lngZeile As Long Dim objFileSystem As Object Dim objVerzeichnis As Object Dim objDateienliste As Object Dim objDatei As Object Dim letztezeile As Integer Dim objFSO As Object Dim objFolder As Object Dim strPfad As String Dim objSubfolder As Object, colSubfolders As Object Dim i As Integer Dim sVerzeichnis1 As String Dim sVerzeichnis2 As String Dim TabBlatt_dateien As String Dim TabBlatt_ordner As String 'C:\Users\HeikoH\Desktop\0002 wiki\data Verzeichnis = ActiveWorkbook.Path 'marke12 Verzeichnis = Verzeichnis & "\ordner" ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis sVerzeichnisA = ActiveWorkbook.Worksheets("ordner").Range("B2").Value ' Files If sVerzeichnisA = "" Then sVerzeichnis2 = Verzeichnis Else sVerzeichnis2 = sVerzeichnisA End If ofs = 20 ' zweites makro zum schreiben der Ordnernamen strPfad = sVerzeichnis2 ' sVerzeichnis2 Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strPfad) Set colSubfolders = objFolder.Subfolders 'i = letztezeile i = 1 ' hier For Each objSubfolder In colSubfolders m = i + ofs Sheets("ordner").Select Range("C" & m).Value = objSubfolder.Name Range("C" & m).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sVerzeichnis2 & "\" & objSubfolder.Name, _ TextToDisplay:=objSubfolder.Name links_zu_foldern(i) = sVerzeichnis2 & "\" & objSubfolder.Name i = i + 1 Next objSubfolder For k = 1 To i ''''ActiveWorkbook.Worksheets("url").Range("G" & CStr(k + 37)).Value = links_zu_foldern(k) 'mar5_4 Next k Set objFolder = Nothing Set colSubfolders = Nothing Set objFSO = Nothing Range("A1").Select End Sub Sub init_filter_quellen() gl_erste_zeile_der_tabelle = 21 gl_letzte_zeile_der_tabelle = 2000 Sheets("quellen").Select Rows(gl_erste_zeile_der_tabelle & ":" & gl_letzte_zeile_der_tabelle).Select Selection.EntireRow.Hidden = True gl_zeile_in_der_das_suchwort_steht = 18 End Sub Sub FILTER_FUER_SPALTE_B_quellen() Call init_filter_quellen Call FILTER_gl("B", "quellen") End Sub Sub init_filter_ordner() gl_erste_zeile_der_tabelle = 21 gl_letzte_zeile_der_tabelle = 2000 Sheets("ordner").Select Rows(gl_erste_zeile_der_tabelle & ":" & gl_letzte_zeile_der_tabelle).Select Selection.EntireRow.Hidden = True gl_zeile_in_der_das_suchwort_steht = 18 End Sub Sub FILTER_FUER_SPALTE_C_ordner() Call init_filter_ordner Call FILTER_gl("C", "ordner") End Sub Sub init_filter_url() gl_erste_zeile_der_tabelle = 21 gl_letzte_zeile_der_tabelle = 2000 Sheets("url").Select Rows(gl_erste_zeile_der_tabelle & ":" & gl_letzte_zeile_der_tabelle).Select Selection.EntireRow.Hidden = True gl_zeile_in_der_das_suchwort_steht = 18 End Sub Sub FILTER_FUER_SPALTE_C_url() Call init_filter_url Call FILTER_gl("C", "url") End Sub Sub FILTER_FUER_SPALTE_D_url() Call init_filter_url Call FILTER_gl("D", "url") End Sub Sub init_filter_inhalt() gl_erste_zeile_der_tabelle = 5 gl_letzte_zeile_der_tabelle = 300 Sheets("Inhaltsverzeichnis").Select Rows(gl_erste_zeile_der_tabelle & ":" & gl_letzte_zeile_der_tabelle).Select Selection.EntireRow.Hidden = True gl_zeile_in_der_das_suchwort_steht = 2 End Sub Sub FILTER_FUER_SPALTE_B_inhalt() If globaL_deb1 = 0 Then 'MsgBox "1234567" Call init_filter_inhalt Call FILTER_gl("B", "Inhaltsverzeichnis") End If End Sub Sub ALLES_EINBLENDEN_JEDE_SEITE() Rows("1:2000").Select Selection.EntireRow.Hidden = False Range("A1").Select End Sub Sub einstellungen() wert = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("D2").Value If wert = 1 Then Columns("E:Q").Select Selection.EntireColumn.Hidden = True ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("D2").Value = 0 Else Columns("D:R").Select Range("R1").Activate Selection.EntireColumn.Hidden = False Range("A2").Select ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("D2").Value = 1 End If End Sub Sub urlnummer() ganzzahl = Application.InputBox("Bitte Zahl eingeben:", Default:=1, Type:=1) ' 1: ganzzahl 2: string zelle = Selection.Address Range(zelle).Select ActiveCell.FormulaR1C1 = "url-nnummer: " & ganzzahl End Sub Sub quellennummer() ganzzahl = Application.InputBox("Bitte Zahl eingeben:", Default:=1, Type:=1) ' 1: ganzzahl 2: string zelle = Selection.Address Range(zelle).Select ActiveCell.FormulaR1C1 = "quellen-nnummer: " & ganzzahl End Sub Sub quellennnummer___() Dim zelle As String Dim new_string As String ganzzahl = Application.InputBox("Bitte Quellen-Nummer eingeben:", Default:=1, Type:=1) ' 1: ganzzahl 2: string zelle = Selection.Address Range(zelle).Select new_string = "quellen-nummer: " & ganzzahl ActiveCell.FormulaR1C1 = new_string Call create__link_param(zelle, new_string, "quellen") End Sub Sub urlnummer____() Dim zelle As String Dim new_string As String ganzzahl = Application.InputBox("Bitte URL-Nummer eingeben:", Default:=1, Type:=1) ' 1: ganzzahl 2: string zelle = Selection.Address Range(zelle).Select new_string = "url-nummer: " & ganzzahl ActiveCell.FormulaR1C1 = new_string Call create__link_param(zelle, new_string, "url") End Sub Sub ordnernummer() Dim zelle As String Dim new_string As String ganzzahl = Application.InputBox("Bitte Ordner-Nummer eingeben:", Default:=1, Type:=1) ' 1: ganzzahl 2: string zelle = Selection.Address Range(zelle).Select new_string = "ordner-nummer: " & ganzzahl ActiveCell.FormulaR1C1 = new_string Call create__link_param(zelle, new_string, "ordner") End Sub Sub create__link_param(zelle_ As String, new_string_ As String, blatt As String) Dim folder_number As String Dim Textt As String Dim MyValue2 As String Dim Default As String 'MsgBox zelle_ 'MsgBox blatt 'MsgBox new_string_ Range(zelle_).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ blatt & "!A1", TextToDisplay:=new_string_ Call add_history End Sub Sub schreibe_text_datei22() Dim bereich As Range Dim zeile As Range Dim zelle As Range Dim s As String Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis Set bereich = Range("B5:C200") Open Verzeichnis & "\inhalt.txt" For Output As #1 For Each zeile In bereich.Rows For Each zelle In zeile.Cells x = zelle.Value Print #1, x Next zelle Next zeile Close #1 End Sub Sub schreibe_text_datei() Dim bereich As Range Dim zeile As Range Dim zelle As Range 'Dim s As String aktueller_name_des_tabellenblattes = ActiveSheet.Name Sheets("Inhaltsverzeichnis").Select Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis Set bereich = Range("B5:B200") Open Verzeichnis & "\inhalt.txt" For Output As #1 For Each zeile In bereich.Rows For Each zelle In zeile.Cells s = s & zelle.Value & " " Next zelle s = Left(s, Len(s) - 1) Print #1, s s = "" Next zeile Close #1 Sheets(aktueller_name_des_tabellenblattes).Select End Sub Sub schreibe_text_datei3333() Dim bereich As Range Dim zeile As Range Dim zelle As Range 'Dim s As String ber = Selection.Address '---> ZELLE Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis '850 'ganzzahl = Application.InputBox("Bitte Zahl eingeben:", Default:=1, Type:=2) ' 1: ganzzahl 2: string Set bereich = Range(ber) Open Verzeichnis & "\inhalt.txt" For Output As #1 For Each zeile In bereich.Rows For Each zelle In zeile.Cells s = s & zelle.Value & " " Next zelle s = Left(s, Len(s) - 1) Print #1, s s = "" Next zeile Close #1 End Sub Sub set_links_inhalt() Verzeichnis = ActiveWorkbook.Path 'marke12 ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value = Verzeichnis ZEILEN_OFFSET = 1 For i = 1 To 1 w = i + ZEILEN_OFFSET hyperlink_blau = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("F1").Value If hyperlink_blau = "" Then Else Range("C2").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ hyperlink_blau, SubAddress:="home", TextToDisplay:="main" End If hyperlink_blau2 = hyperlink_blau & "/wiki.pptx" Range("C1").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ hyperlink_blau2, SubAddress:="home", TextToDisplay:="wiki.pptx" Next i End Sub 'hhhh Sub a11_schreibeX_() Dim i As Integer Dim speichere As Integer Dim m As String Dim savename As String Dim aktueller_name As String Dim name__ As String Dim sddddateiName As String 'sddddateiName = Tabelle17.Range("H1").Value 'MsgBox "1234567" speichere = 999 aktueller_name = "x" 'MsgBox (aktueller_Name) For i = 5 To 300 Step 1 m = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("D" & i).Value ' 756 If (m = aktueller_name) Then speichere = i savename = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & i).Value 'MsgBox (speichere) End If Next i If speichere = 999 Then ''''MsgBox "kein x gesetzt" Exit Sub End If Sheets("Inhaltsverzeichnis").Select Range("B" & speichere).Select ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("J1").Value = savename Range("A1").Select Call a10_filter_ Call del_x End Sub Sub a10_filter_() Dim i As Integer Dim speichere As Integer Dim m As String Dim saveebene As String Dim aktueller_name As String Dim name__ As String 'Dim sddddateiName As String 'sddddateiName = Tabelle17.Range("H1").Value Call ALLES_EINBLENDEN_JEDE_SEITE speichere = 1 aktueller_name = Worksheets("Inhaltsverzeichnis").Range("J1") 'MsgBox (aktueller_Name) For i = 2 To 300 Step 1 m = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & i).Value If (m = aktueller_name) Then speichere = i saveebene = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & i).Value 'MsgBox (speichere) End If Next i Sheets("Inhaltsverzeichnis").Select Range("B" & speichere).Select If saveebene = "1" Then For i = (speichere + 1) To 300 Step 1 m = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & i).Value If (m = "1") Then speichere2 = i 'MsgBox (speichere2) Exit For End If Next i End If If saveebene = "2" Then For i = (speichere + 1) To 300 Step 1 m = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("C" & i).Value If (m = "1") Or (m = "2") Then speichere2 = i 'MsgBox (speichere2) Exit For End If Next i End If Sheets("Inhaltsverzeichnis").Select Range("B" & speichere).Select ' ausblenden vom vorderne bereich Rows("5:" & (speichere - 1)).Select Selection.EntireRow.Hidden = True 'If aktueller_Name <> "ende2" Then If aktueller_name <> "ende" Then ' was danach kommt If speichere2 <> "" Then Rows(speichere2 & ":103").Select 'problemhier Selection.EntireRow.Hidden = True ActiveWindow.ScrollRow = 1 Range("A1").Select End If End If End Sub Sub del_x() ' ' Makro3 Makro ' ' Range("D5:D102").Select Selection.ClearContents Range("A3").Select End Sub Sub set_links_wiki() ZEILEN_OFFSET = 20 For i = 1 To 300 w = i + ZEILEN_OFFSET hyperlink_blau = ActiveWorkbook.Worksheets("url").Range("F" & w).Value If hyperlink_blau = "" Then Else beschr = ActiveWorkbook.Worksheets("url").Range("D" & w).Value Range("E" & w).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ hyperlink_blau, SubAddress:="home", TextToDisplay:="LINK" ActiveWorkbook.Worksheets("url").Range("B" & w).Value = i Range("D" & w).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ hyperlink_blau, SubAddress:="home", TextToDisplay:=beschr End If Next i Range("A1").Select End Sub Sub loesche_element() ganzzahl = Application.InputBox("Wirklich loeschen (j/n)", Default:="n", Type:=2) ' 1: ganzzahl 2: string If ganzzahl = "j" Then akt_zeile = ActiveCell.Row inhalt_of_zeile = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B" & akt_zeile).Value Rows(akt_zeile & ":" & akt_zeile).Select Selection.Delete Shift:=xlUp Sheets(inhalt_of_zeile).Select ActiveWindow.SelectedSheets.Delete End If Sheets("Inhaltsverzeichnis").Select End Sub Sub todo_formatierung() ' ' Makro8 Makro ' ' Columns("B:B").Select Selection.FormatConditions.Add Type:=xlTextString, String:="todo", _ TextOperator:=xlContains Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False Selection.FormatConditions.Add Type:=xlTextString, String:="done", _ TextOperator:=xlContains Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font .Color = -16752384 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13561798 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False Columns("B:B").Select Selection.FormatConditions.Add Type:=xlTextString, String:="wait", _ TextOperator:=xlContains Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font .Color = -16754788 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 10284031 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False End Sub Sub schreibe_historie_alt() ' Dim aktueller_name As String aktueller_name = CStr(ActiveSheet.Name) 'ActiveWorkbook.Worksheets(aktueller_name).Range("A2").Value = Format(Now, "YYYY" & "_" & "MM" & "_" & "DD" & "||||" & "hh" & "_" & "mm" & "_" & "ss") 'm = ActiveWorkbook.Worksheets(aktueller_name).Range("A1").Value Sheets("historie").Select Range("B5:F5").Select Range(Selection, Selection.End(xlDown)).Select Selection.Cut Range("B6").Select ActiveSheet.Paste Range("A2").Select ActiveWorkbook.Worksheets("Historie").Range("B5").Value = aktueller_name ActiveWorkbook.Worksheets("Historie").Range("F5").Value = Format(Now, "YYYY" & "_" & "MM" & "_" & "DD" & "_|||_" & "hh" & "_" & "mm" & "_" & "ss") Range("B5").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ aktueller_name & "!A1", TextToDisplay:=aktueller_name Sheets(aktueller_name).Select End Sub Sub schreibe_historie() ' Dim aktueller_name As String aktueller_name = CStr(ActiveSheet.Name) 'ActiveWorkbook.Worksheets(aktueller_name).Range("A2").Value = Format(Now, "YYYY" & "_" & "MM" & "_" & "DD" & "||||" & "hh" & "_" & "mm" & "_" & "ss") 'm = ActiveWorkbook.Worksheets(aktueller_name).Range("A1").Value ZEILEN_OFFSET = 4 Dim wert(1 To 200) As String Dim zeit(1 To 200) As String For i = 1 To 150 w = i + ZEILEN_OFFSET wert(i) = ActiveWorkbook.Worksheets("historie").Range("B" & w).Value zeit(i) = ActiveWorkbook.Worksheets("historie").Range("F" & w).Value Next i ZEILEN_OFFSET = 5 For i = 1 To 150 w = i + ZEILEN_OFFSET ActiveWorkbook.Worksheets("historie").Range("B" & w).Value = wert(i) ActiveWorkbook.Worksheets("historie").Range("F" & w).Value = zeit(i) Next i ActiveWorkbook.Worksheets("Historie").Range("B5").Value = aktueller_name ActiveWorkbook.Worksheets("Historie").Range("F5").Value = Format(Now, "YYYY" & "_" & "MM" & "_" & "DD" & "_|||_" & "hh" & "_" & "mm" & "_" & "ss") Sheets("historie").Select Range("B5").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ aktueller_name & "!A1", TextToDisplay:=aktueller_name Sheets(aktueller_name).Select End Sub Sub ONE_PAGEdina3FormatUndAllesAufEineSeiteDrucken() Dim AnzahlTabBlaetter As Integer AnzahlTabBlaetter = ActiveWorkbook.Sheets.Count Dim schreibe_seite As String name_tab = ActiveSheet.Name Sheets(name_tab).Select Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 0 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA5 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With Application.PrintCommunication = True ActiveSheet.PageSetup.PrintArea = "" Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.787401575) .BottomMargin = Application.InchesToPoints(0.787401575) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Application.PrintCommunication = True Range("A1").Select End Sub '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen 'A) steht in B5 'show all Sub xx240a_3elementFilter_einbl_SHOW_ALL__() 'Call zz99a_write_nr 'MsgBox nr__ nr__ = 5 nr__ende = 2000 'Rows(nr__ & ":2000").Select Rows(nr__ & ":" & nr__ende).Select Selection.EntireRow.Hidden = False Range("A1").Select End Sub 'show headlines__ Sub xx240xxx_A_xxx_3elementFilter_SHOW_headlines__() '-------------------------------------------------------------------------------------------------------------------------------- Call xx240a_3elementFilter_ausbl__ Call xx240xxxxxx_3elementFilter_filter__("B") End Sub 'show one chapter Sub xx245_start__() Dim aktuelle_zeile As Integer aktuelle_zeile = ActiveCell.Row Call xx240a_3elementFilter_einbl_SHOW_ALL__ Call xx241__(aktuelle_zeile) Range("A4").Select End Sub Sub xx240a_3elementFilter_ausbl__() 'Call zz99a_write_nr nr__ = 5 nr__ende = 2000 'Rows(nr__ & ":2000").Select Rows(nr__ & ":" & nr__ende).Select Selection.EntireRow.Hidden = True Range("A1").Select End Sub Sub xx240xxxxxx_3elementFilter_filter__(buchst As String) '--------------------------------------------------------------------- abs 0 variablen Dim aktueller_name As String Dim ssspalte As String Dim AAarray(1 To 2000) As String Dim m As String Dim Message, Title, Default, sStringEingabe As String Dim aktueller_Name_gl_new As String Dim spalte_als_zahl As Integer Dim MyValue As String Dim buchstabe_im_alphabet_lo2 As String Dim ende_des_filters As Integer Dim wert_in_zelle As String Dim he As Integer '--------------------------------------------------------------------- abs 1 write tabellenblatt, zeile und spalte aktueller_name = CStr(ActiveSheet.Name) MyValue = ActiveCell.Row spalte_als_zahl = ActiveCell.Column '--------------------------------------------------------------------- abs 2 mache aus spalten-zahl ein spalten-buchstabe 'Call z99a_mache_aus_zahl_ein_buchstaben(spalte_als_zahl) ' return buchstabe__ '--------------------------------------------------------------------- abs 3 in variable steht die aktive spalte 'buchstabe_im_alphabet_lo = buchstabe__ buchstabe_im_alphabet_lo = buchst '--------------------------------------------------------------------- abs 4 spezialfall plus filter If global__choice = 0 Then sStringEingabe = "+" ' für filter plus funktion ElseIf global__choice = 1 Then sStringEingabe = "#p" ' für filter plus funktion ElseIf global__choice = 2 Then sStringEingabe = "x" ' für filter plus funktion End If If globale_var = 0 Then Message = "Filter nach ..... " Title = "InputBox" Default = "+" 'sStringEingabe = InputBox(Message, Title, Default) End If 'MsgBox sStringEingabe sStringEingabe = ")" '--------------------------------------------------------------------- abs 5 allle einblenden, die die stringkombination enthalten ende_des_filters = 2000 For k = 5 To ende_des_filters Step 1 e = k AAarray(k) = ActiveWorkbook.Worksheets(aktueller_name).Range(buchstabe_im_alphabet_lo & e).Value h = InStrRev(AAarray(k), sStringEingabe, , vbTextCompare) If (h > 0) Then Rows(e & ":" & e).Select Selection.EntireRow.Hidden = False ' hiier End If Next k End Sub Sub xx241__(uebergabe As Integer) Dim ooofs As Integer Dim letzte__zeile_lo As Integer Dim merke_das As Integer Dim m As Integer Dim wert_in_b As String Dim flag As Integer flag = 1 'letzte__zeile_lo = ActiveSheet.Cells(1048576, 3).End(xlUp).Row nam_bl = ActiveSheet.Name 'ooofs = 9 ooofs = uebergabe sStringEingabe = ")" For i = 1 To (300) m = i + ooofs wert_in_b = ActiveWorkbook.Worksheets(nam_bl).Range("B" & m).Value '690 h = InStrRev(wert_in_b, sStringEingabe, , vbTextCompare) If (h > 0) And flag = 1 Then flag = 0 merke_das = m End If Next i 'MsgBox merke_das Call xx242__(uebergabe, merke_das) End Sub Sub xx242__(param1 As Integer, param2 As Integer) Dim flag As Integer flag = 0 param1 = param1 - 1 If param1 < 5 Then param1 = 5 flag = 1 End If If flag = 0 Then Rows("5:" & param1).Select 'Range("A8").Activate Selection.EntireRow.Hidden = True End If Rows(param2 & ":2000").Select 'Range("A16").Activate Selection.EntireRow.Hidden = True Range("M1").Select 'Rows("5:8").Select 'Range("A8").Activate 'Selection.EntireRow.Hidden = True 'Rows("12:16").Select 'Range("A16").Activate 'Selection.EntireRow.Hidden = True 'Range("M1").Select End Sub '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen '------------------------------------------------------------------------------------------- Zweistufige Gliederungsebenen ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_from_line_to_column() ' copy_it(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Call copy_it1("T19", "Y19", "historie", "historie") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_from_column_to_line() ' copy_it(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Call copy_it2("U28", "W28", "historie", "historie") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_area() ' copy_it(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Call copy_it3("U35:V36", "X42:Y43", "historie", "historie") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_from_column_to_column() ' copy_it(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Call copy_it10("U28", "W28", "historie", "historie") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_from_line_to_line() ' copy_it(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Call copy_it20("T19", "Y19", "historie", "historie") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_it1(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Sheets(start_blatt).Select Range(start_wert).Select Range(Selection, Selection.End(xlToRight)).Select Selection.Copy Sheets(end_blatt).Select Range(end_wert).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True End Sub Sub copy_it2(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Sheets(start_blatt).Select Range(start_wert).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets(end_blatt).Select Range(end_wert).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True End Sub Sub copy_it3(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) ' ' Makro8 Makro ' Sheets(start_blatt).Select Range(start_wert).Select Selection.Copy Sheets(end_blatt).Select Range(end_wert).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Sub copy_it10(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Sheets(start_blatt).Select Range(start_wert).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets(end_blatt).Select Range(end_wert).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Sub copy_it20(start_wert As String, end_wert As String, start_blatt As String, end_blatt As String) Sheets(start_blatt).Select Range(start_wert).Select Range(Selection, Selection.End(xlToRight)).Select Selection.Copy Sheets(end_blatt).Select Range(end_wert).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Sub finde_die_letzte_zeile_2000() flag = 1 erste_zeile_der_liste = 21 offset = erste_zeile_der_liste - 1 For i = 1 To 1000 zeile = i + offset iterations_wert_wert_der_liste = ActiveWorkbook.Worksheets("quellen").Range("B" & zeile).Value If iterations_wert_wert_der_liste = "" And flag = 1 Then flag = 0 merke_dir_die_erste_freie_zeile = zeile End If Next i Range("B" & merke_dir_die_erste_freie_zeile).Select End Sub Sub finde_die_letzte_zeile_3000() flag = 1 erste_zeile_der_liste = 21 offset = erste_zeile_der_liste - 1 For i = 1 To 1000 zeile = i + offset iterations_wert_wert_der_liste = ActiveWorkbook.Worksheets("ordner").Range("C" & zeile).Value If iterations_wert_wert_der_liste = "" And flag = 1 Then flag = 0 merke_dir_die_erste_freie_zeile = zeile End If Next i Range("C" & merke_dir_die_erste_freie_zeile).Select End Sub Sub finde_die_letzte_zeile_4000() flag = 1 erste_zeile_der_liste = 20 offset = erste_zeile_der_liste - 1 For i = 1 To 1000 zeile = i + offset iterations_wert_wert_der_liste = ActiveWorkbook.Worksheets("url").Range("F" & zeile).Value If iterations_wert_wert_der_liste = "" And flag = 1 Then flag = 0 merke_dir_die_erste_freie_zeile = zeile End If Next i Range("F" & merke_dir_die_erste_freie_zeile).Select End Sub Sub filtere_z() zzelle = ActiveCell.Address inh = ActiveWorkbook.Worksheets("ordner").Range(zzelle).Value ActiveWorkbook.Worksheets("ordner").Range("C18").Value = inh End Sub Sub filtere_h() zzelle = ActiveCell.Address inh = ActiveWorkbook.Worksheets("quellen").Range(zzelle).Value ActiveWorkbook.Worksheets("quellen").Range("B18").Value = inh End Sub Sub filtere_k() zzelle = ActiveCell.Address inh = ActiveWorkbook.Worksheets("url").Range(zzelle).Value ActiveWorkbook.Worksheets("url").Range("C18").Value = inh End Sub Sub startseite() zzelle = ActiveCell.Address inh = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range(zzelle).Value ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B2").Value = inh End Sub Sub filtere_m() zzelle = ActiveCell.Address inh = ActiveWorkbook.Worksheets("url").Range(zzelle).Value ActiveWorkbook.Worksheets("url").Range("D18").Value = inh End Sub Sub fast_search() ' alt: str d Dim ssstring As String ssstring = "Bitte Skript wählen" _ & Chr(13) _ & Chr(13) _ & Chr(13) _ & Chr(13) _ & "1: Inhaltsverzeichnis" _ & Chr(13) _ & Chr(13) _ & "2: Quellen" _ & Chr(13) _ & Chr(13) _ & "3: Ordner" _ & Chr(13) _ & Chr(13) _ & "4: URL" _ & Chr(13) _ & Chr(13) ' schreibe_historie 'default_val = ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("H4").Value default_val = 4 Message = ssstring Title = "InputBox" Default1 = default_val sNummer = InputBox(Message, Title, Default1) If sNummer = "1" Or sNummer = "2" Or sNummer = "3" Or sNummer = "4" Then iNummer = CInt(sNummer) 'MsgBox iNummer suche_das = Application.InputBox("SUCHE .....", Default:=1, Type:=2) ' 1: ganzzahl 2: string 'bl = ActiveSheet.Name If iNummer = 1 Then Sheets("Inhaltsverzeichnis").Select ActiveWorkbook.Worksheets("Inhaltsverzeichnis").Range("B2").Value = suche_das ElseIf iNummer = 2 Then Sheets("quellen").Select ActiveWorkbook.Worksheets("quellen").Range("B18").Value = suche_das ElseIf iNummer = 3 Then Sheets("ordner").Select ActiveWorkbook.Worksheets("ordner").Range("C18").Value = suche_das ElseIf iNummer = 4 Then Sheets("url").Select ActiveWorkbook.Worksheets("url").Range("D18").Value = suche_das Else End If Else MsgBox "bitte zahl zwischen 1 und 4 eingeben" End If End Sub Sub write_date() zel = Selection.Address ActiveWorkbook.Worksheets("todo").Range(zel).Value = Format(Now, "YYYY" & " " & "MM" & " " & "DD" & " ||| " & "hh" & ":" & "mm") End Sub Sub write_date2() zel = Selection.Address ActiveWorkbook.Worksheets("todo").Range(zel).Value = Format(Now, "YYYY" & " " & "MM" & " " & "DD") End Sub Sub add_checkboxes() ' ' Makro2ff Makro ' Dim xxx As Range Dim Textt Textt = Selection.Address 'MsgBox Textt 'xxx = ActiveSheet.UsedRange 'MsgBox ActiveSheet.UsedRange.Select ' Range("N7:N19").Select Range(Textt).Select ' Range(xxx).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection.Font .Name = "Marlett" .Size = 11 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With Range(Textt).Select End Sub 'Video_034) VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO VIDEO Video_034) ende