Suchen und ersetzen

[RoAdRuNnEr]

Also nochmal anders erklärt.
Wenn man in Excel eine Tabelle hat, die zum Beispiel 15000 Einträge oder Zeilen hat, dann ist ja seitens Excel Links automatisch
eine Nummerierung eingefügt die in Zeile 1 logischerweise auch mit 1 beginnt.
Das gleiche ist in den Spalten, wo die erste Spalte A heisst und die nächste Spalte B usw.
Ok soweit, sogut.
Wenn jetzt eine Tabelle von 15000 Einträgen da ist verzieht sich die ganze Tabelle (dank der eingeschaltenen Zeilen und Spaltenanzeige) ab der Zeile 1000
um einen tick nach Rechts. Das gleiche Passiert dann wieder wenn die Zeile 10000 kommt.
Somit schiebt die Tabelle sich 2 x nach Rechts.
Um dieses zu vermeiden habe ich in Spalte A gesondert eine Nummerierung eingeführt die ab Zeile 2 mit 00001 beginnt und dann fortlaufend in Zeile 3 mit 00002 fortgeführt wird.
In Zeile 1 der Spalte A befindet sich die Überschrift dieser Spalte die ich "Nr." genannt habe.
Die Eigentliche, von Excel gezeigte Spalten und Zeilenanzeige habe ich abgestellt.
Die gesamte Zeile 1 ist bei allen Spalte fest gesetzt als überschrift und bleibt auch dort, wenn man in der Tabelle hin und herscrollt.
Ich hoffe das es bis hier hin Verständlich erklärt ist.
Jetzt möchte ich Natürlich nicht immer wieder aufs neue in Spalte 1 diese 00001 immer wieder eintippen müssen und diese dann bis zum letzten Eintrag unten in dieser Tabelle
mit gedrückter Linker Maustaste ziehen wollen.
Deswegen die Frage, ob es Möglich sei, daß das Makro immer wieder automatischdie Nummerierung  ausführen kann bis zur letzten Zeile beginnend in der Zeile 2 in Spalte A mit dem Wert 00001 (da sich die Tabelle immer wieder vergrößert in den Zeilen, wenn neue Einträge hinzugefügt worden sind)

Sinn und Zweck des ganzen ist, da ich während des streamen immer eine bestimmte Zeile und darin mehrere Spalten seperat von einem anderen Programm anzeigen lasse und diese sich dann verschieben würden, sodaß das ganze Bild der Einzelnen Zellen verschoben hätte, ich dieses dann mit meiner Methode anwenden könnte, ohne das sich ab Zeile 1000 oder 10000 sich eine Verschiebung ereignen würde.

[RoAdRuNnEr]

Am besten wäre es , wenn wir Uns mal treffen würden, auf Discord oder per Teamviewer, dann kann man auch ganz anders argumentieren und ausdrücken, was man möchte...

Sofern Du Discord besitzt : RoAdRuNnEr#0457

Ich denke das wäre die beste Wahl, dann kann ich Dir auch mittels Liveübertragung zeigen wie ich das gerne hätte und Du könntest dementsprechend danach handeln.
Geht X-mal schneller als das immer nur "Stück für Stück" im Forum zu diskutieren.

[Rudi'S]

Hallo,
wenn du weiter Hilfe haben möchtest, solltest du dem Wunsch von Gast 123 schon folgen. 
Die Ansage verschiebt sich usw. lässt sich doch wunderbar an einer kleinen Beispieldatei (mit Wunschergebnis) zeigen, so ist dein Wunsch leider nicht unbedingt erkennbar.
Vielleicht erfreuen sich auch Andere an den Ergebnissen, dafür ist das Forum ja da.

Reicht ja ein Ausschnitt von a1 bis z.B. K10, denn dir kommt es ja wohl im Wesentlichen auf die Fortführung der Aufzählung der Werte aus Spalte A an.

Gruß Rudi

[RoAdRuNnEr]

Also nach langer tüftelei und recherchen im Internet habe ich nun die Lösung.

Beispiel :

In Spalte A, Zeile 2 trage ich eine 00001 ein
dann gehe ich in der selben Zelile (A2) mit dem Cursor Rechts unten  bis ein kleines Kreuz Symbol erscheint  und klicke 2 x mit der Linken Maustaste drauf (damit makiert er in Spalte A alle Zeilen die auch bis zur Nachbarspalte B mit Buchstaben oder Zahlen zu sehen sind). Wichtig dabei ist das in der Nachbarspalte "B" keine Leerzeile sich befinden darf, sonst wird in Spalte "A" nur bis zu der Zeile die Zellen ausgewählt, bis die Leerzeile in Spalte "B" erreicht ist.

Nachdem nun alle Zellen Exakt gleich von der Länge ausgewählt sind wie in Spalte "B" kann man mit der Tastenkombination

STRG + U die Zeilen vervollständigen. In dem Falle in Spalte "A" Zeile 2 eingefügte "00001".
Die Nummerierung ist somit nun Fortlaufend bis ans Ende.

[Gast 123]

Hallo

freut mich das du die Lösung selbst gefunden hast = Hilfe zur Selbsthilfe, der Grundgedanke des Forum. Ich schliesse den Thread damit ab.

mfg Gast 123

[RoAdRuNnEr]

Ich möchte mich Nochmaligst an alle User bedanken die mir von Thread 1 bis zuletzt geholfen haben.

Ich werde desweiteren diese Webseite weiterempfehlen, weil einem Wirklich geholfen wird und während
des Schriftverkehrs zu keinerlei Beleidigungen, Anspielungen, etc. zu Stande gekommen ist, was in dieser
Zeit Echt selten vorkommt.

Vielen Dank Euch allen !

[RoAdRuNnEr]

Hallo....und bitte nicht schlagen...hehe...

hab da doch noch ein kleines Problem gefunden...

Habe jetzt Erfolgreich ein Makro aufgezeichnet und das Makro von Gast123 noch mit inplementiert und alles läuft wie es laufen solll.
Da jetzt die unbehandelte Tabelle sich vergrößert hat (weil neue Zeilen dazugekommen sind) und ich diese mit meinem aufgezeichnetem
Makro erneut ausprobieren wollte, ergab sich folgender Fehler.
Alles was in der Ursprungstabelle "neu" dazugekommen ist wird Quasi von dem Makro nicht erkannt und bleibt in den untersten Zeilen.
Wie muß man das Makro umschreiben, sodaß er die neuen Zeilen auch anerkennt (und das jedesmal wenn sich die Tabelle erweitert hat ?
In dem Falle lief alles gut bis in Zeile 11078. Nachdem die Ursprungstabelle neue Zeilen hinzubekommen hat, arbeitet das Makro sich nur bis
Zeile 11078 vor und nimmt "nicht" die neuen Werte mit.

Meine Frage ist nun, wie man dem Makro beibringen kann alles bis zum Ende zu überprüfen und nicht nur bis Zeile 11078 zu arbeiten ?
Noch als Nachtrag... als ich das Makro aufzeichnete ging die zu bearbeitende Tabelle bis Zeile 11078 und liegt aktuell bei 11090 und vergrößert sich fast täglich,
sodaß ich immer wieder neu das Makro ausführen möchte/muß.
Desweiteren gehe ich davon aus, daß man alles was mit der Zahl 11078 in diesem MAkro zu tun hat ändern müsste, aber die Frage ist wie ?

Hier mein Makroauszug :

Code:

Sub Tabelle()
'
' Tabelle Makro
' Tabelle TS2021
'
' Tastenkombination: Strg+a
'
    Columns("D:D").Select
    ActiveWorkbook.Worksheets("SQLiteAdmin").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("SQLiteAdmin").Sort.SortFields.Add2 Key:=Range( _
        "D1:D11078"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("SQLiteAdmin").Sort
        .SetRange Range("A1:AE11078")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWindow.ScrollRow = 29
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 100
    ActiveWindow.ScrollRow = 142
    ActiveWindow.ScrollRow = 171
    ActiveWindow.ScrollRow = 213
    ActiveWindow.ScrollRow = 242
    ActiveWindow.ScrollRow = 284
    ActiveWindow.ScrollRow = 341
    ActiveWindow.ScrollRow = 454
    ActiveWindow.ScrollRow = 511
    ActiveWindow.ScrollRow = 667
    ActiveWindow.ScrollRow = 809
    ActiveWindow.ScrollRow = 1021
    ActiveWindow.ScrollRow = 1177
    ActiveWindow.ScrollRow = 1504
    ActiveWindow.ScrollRow = 1645
    ActiveWindow.ScrollRow = 1986
    ActiveWindow.ScrollRow = 2113
    ActiveWindow.ScrollRow = 2510
    ActiveWindow.ScrollRow = 2709
    ActiveWindow.ScrollRow = 3148
    ActiveWindow.ScrollRow = 3304
    ActiveWindow.ScrollRow = 3673
    ActiveWindow.ScrollRow = 3886
    ActiveWindow.ScrollRow = 4141
    ActiveWindow.ScrollRow = 4198
    ActiveWindow.ScrollRow = 4311
    ActiveWindow.ScrollRow = 4340
    ActiveWindow.ScrollRow = 4368
    ActiveWindow.ScrollRow = 4396
    ActiveWindow.ScrollRow = 4425
    ActiveWindow.ScrollRow = 4453
    ActiveWindow.ScrollRow = 4637
    ActiveWindow.ScrollRow = 4722
    ActiveWindow.ScrollRow = 4893
    ActiveWindow.ScrollRow = 4935
    ActiveWindow.ScrollRow = 5119
    ActiveWindow.ScrollRow = 5361
    ActiveWindow.ScrollRow = 5630
    ActiveWindow.ScrollRow = 5729
    ActiveWindow.ScrollRow = 6084
    ActiveWindow.ScrollRow = 6226
    ActiveWindow.ScrollRow = 6537
    ActiveWindow.ScrollRow = 6679
    ActiveWindow.ScrollRow = 6920
    ActiveWindow.ScrollRow = 6934
    ActiveWindow.ScrollRow = 6963
    ActiveWindow.ScrollRow = 6977
    ActiveWindow.ScrollRow = 6991
    ActiveWindow.ScrollRow = 7034
    ActiveWindow.ScrollRow = 7119
    ActiveWindow.ScrollRow = 7218
    ActiveWindow.ScrollRow = 7232
    ActiveWindow.ScrollRow = 7246
    ActiveWindow.ScrollRow = 7261
    ActiveWindow.ScrollRow = 7289
    ActiveWindow.ScrollRow = 7317
    ActiveWindow.ScrollRow = 7360
    ActiveWindow.ScrollRow = 7374
    ActiveWindow.ScrollRow = 7388
    ActiveWindow.ScrollRow = 7417
    ActiveWindow.ScrollRow = 7431
    ActiveWindow.ScrollRow = 7445
    ActiveWindow.ScrollRow = 7459
    ActiveWindow.ScrollRow = 7473
    ActiveWindow.ScrollRow = 7502
    ActiveWindow.ScrollRow = 7516
    ActiveWindow.ScrollRow = 7544
    ActiveWindow.ScrollRow = 7587
    ActiveWindow.ScrollRow = 7643
    ActiveWindow.ScrollRow = 7729
    ActiveWindow.ScrollRow = 7757
    ActiveWindow.ScrollRow = 7899
    ActiveWindow.ScrollRow = 7970
    ActiveWindow.ScrollRow = 8225
    ActiveWindow.ScrollRow = 8310
    ActiveWindow.ScrollRow = 8508
    ActiveWindow.ScrollRow = 8551
    ActiveWindow.ScrollRow = 8664
    ActiveWindow.ScrollRow = 8721
    ActiveWindow.ScrollRow = 8835
    ActiveWindow.ScrollRow = 8891
    ActiveWindow.ScrollRow = 9076
    ActiveWindow.ScrollRow = 9175
    ActiveWindow.ScrollRow = 9345
    ActiveWindow.ScrollRow = 9388
    ActiveWindow.ScrollRow = 9473
    ActiveWindow.ScrollRow = 9515
    ActiveWindow.ScrollRow = 9586
    ActiveWindow.ScrollRow = 9643
    ActiveWindow.ScrollRow = 9742
    ActiveWindow.ScrollRow = 9799
    ActiveWindow.ScrollRow = 9898
    ActiveWindow.ScrollRow = 9941
    ActiveWindow.ScrollRow = 10026
    ActiveWindow.ScrollRow = 10068
    ActiveWindow.ScrollRow = 10168
    ActiveWindow.ScrollRow = 10196
    ActiveWindow.ScrollRow = 10295
    ActiveWindow.ScrollRow = 10338
    ActiveWindow.ScrollRow = 10380
    ActiveWindow.ScrollRow = 10394
    ActiveWindow.ScrollRow = 10409
    ActiveWindow.ScrollRow = 10423
    ActiveWindow.ScrollRow = 10437
    ActiveWindow.ScrollRow = 10465
    ActiveWindow.ScrollRow = 10494
    ActiveWindow.ScrollRow = 10522
    ActiveWindow.ScrollRow = 10536
    ActiveWindow.ScrollRow = 10550
    ActiveWindow.ScrollRow = 10565
    ActiveWindow.ScrollRow = 10579
    ActiveWindow.ScrollRow = 10607
    ActiveWindow.ScrollRow = 10735
    ActiveWindow.ScrollRow = 10862
    ActiveWindow.ScrollRow = 11033
    Rows("11078:11078").Select
    Selection.Copy
    ActiveWindow.ScrollRow = 11018
    ActiveWindow.ScrollRow = 11004
    ActiveWindow.ScrollRow = 10976
    ActiveWindow.ScrollRow = 10919
    ActiveWindow.ScrollRow = 10706
    ActiveWindow.ScrollRow = 10565
    ActiveWindow.ScrollRow = 10281
    ActiveWindow.ScrollRow = 10153
    ActiveWindow.ScrollRow = 9615
    ActiveWindow.ScrollRow = 9416
    ActiveWindow.ScrollRow = 9061
    ActiveWindow.ScrollRow = 8877
    ActiveWindow.ScrollRow = 8480
    ActiveWindow.ScrollRow = 8324
    ActiveWindow.ScrollRow = 7927
    ActiveWindow.ScrollRow = 7785
    ActiveWindow.ScrollRow = 7573
    ActiveWindow.ScrollRow = 7488
    ActiveWindow.ScrollRow = 7176
    ActiveWindow.ScrollRow = 7020
    ActiveWindow.ScrollRow = 6594
    ActiveWindow.ScrollRow = 6296
    ActiveWindow.ScrollRow = 5956
    ActiveWindow.ScrollRow = 5701
    ActiveWindow.ScrollRow = 5389
    ActiveWindow.ScrollRow = 5148
    ActiveWindow.ScrollRow = 4893
    ActiveWindow.ScrollRow = 4779
    ActiveWindow.ScrollRow = 4410
    ActiveWindow.ScrollRow = 4297
    ActiveWindow.ScrollRow = 3886
    ActiveWindow.ScrollRow = 3673
    ActiveWindow.ScrollRow = 3375
    ActiveWindow.ScrollRow = 3276
    ActiveWindow.ScrollRow = 2936
    ActiveWindow.ScrollRow = 2794
    ActiveWindow.ScrollRow = 2439
    ActiveWindow.ScrollRow = 2326
    ActiveWindow.ScrollRow = 2113
    ActiveWindow.ScrollRow = 2028
    ActiveWindow.ScrollRow = 1801
    ActiveWindow.ScrollRow = 1716
    ActiveWindow.ScrollRow = 1376
    ActiveWindow.ScrollRow = 1305
    ActiveWindow.ScrollRow = 1163
    ActiveWindow.ScrollRow = 1135
    ActiveWindow.ScrollRow = 1050
    ActiveWindow.ScrollRow = 993
    ActiveWindow.ScrollRow = 865
    ActiveWindow.ScrollRow = 795
    ActiveWindow.ScrollRow = 653
    ActiveWindow.ScrollRow = 596
    ActiveWindow.ScrollRow = 497
    ActiveWindow.ScrollRow = 440
    ActiveWindow.ScrollRow = 341
    ActiveWindow.ScrollRow = 298
    ActiveWindow.ScrollRow = 185
    ActiveWindow.ScrollRow = 142
    ActiveWindow.ScrollRow = 71
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 1
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    Selection.Delete Shift:=xlToLeft
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Windows("Strecken.xls").Activate
    Columns("A:B").Select
    Selection.Copy
    Windows("Aufgaben.xls").Activate
    Columns("L:M").Select
    ActiveSheet.Paste
    Columns("O:AA").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("A:M").Select
    With Selection.Font
        .Color = -16727809
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 4.99893185216834E-02
        .PatternTintAndShade = 0
    End With
    Columns("N:N").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    Columns("N:N").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("C:C").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("G:G").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight
    Range("A1").Select
    Columns("A:A").Select
    Selection.ClearContents
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=TEXT(ROW(R[-1]C),""00000"")"
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A11079")
    Range("A2:A11079").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "'Nr."
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "'Szenario Name :"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "'Strecke :"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "'Beschreibung :"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "'Aufgabe :"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "'Startzeit :"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "'S"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "'Spielerfahrzeug :"
    Range("A1:F1").Select
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("K1").Select
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("G1:J1").Select
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Columns("A:A").Select
    Selection.ColumnWidth = 5
    Columns("B:B").Select
    Selection.ColumnWidth = 50
    Columns("C:C").Select
    Selection.ColumnWidth = 45
    Columns("D:D").Select
    Selection.ColumnWidth = 82
    Columns("E:E").Select
    Selection.ColumnWidth = 19
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "'min."
    With ActiveCell.Characters(Start:=1, Length:=0).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=4, Length:=1).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "'Aufgabe :"
    Columns("E:E").Select
    Selection.ColumnWidth = 19
    Columns("F:F").Select
    Selection.ColumnWidth = 3
    Columns("G:G").Select
    Selection.ColumnWidth = 5
    Columns("H:H").Select
    Selection.ColumnWidth = 7
    Columns("I:I").Select
    Selection.ColumnWidth = 8
    Columns("J:J").Select
    Selection.ColumnWidth = 1
    Columns("K:K").Select
    Selection.ColumnWidth = 38
    ActiveWindow.DisplayHeadings = False
    Dim rFind As Range, lz2 As Long
Dim Adr1 As Variant, n As Long
    Adr1 = Right(Range("C2"), 4)
    'Prüfen ob Makro ausgeführt wurde!
    If Not IsNumeric(Adr1) Then
      MsgBox "In Zelle C1 steht bereits Text! - Abbruch!": Exit Sub
    End If
 
    '** LastZell in Spalte -K- suchen
    lz1 = Cells(Rows.Count, 12).End(xlUp).Row
    lz2 = Cells(Rows.Count, 3).End(xlUp).Row
    'kopiere Spalte C nach Spalte N    (Sicherheits Kopie)
    Range("C2:C" & lz2).Copy
    Range("N2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

    'Suche RoutenNummer in Spalte C
    For Each AC In Range("L2:L" & lz1)
      Application.StatusBar = AC.Row & "  /  " & lz1 & "  /  " & n
      Set rFind = Columns(3).Find(What:=AC, After:=[c1], LookIn:=xlFormulas, LookAt:= _
          xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
 
      If Not rFind Is Nothing Then
          Adr1 = rFind.Address
          Do
            n = n + 1  'gedunden Daten zaehlen
            'Text aus Spalte B nach D ausgeben
              rFind.Value = AC.Offset(0, 1)
            'weitersuchen (falls mehrfach vorhanden)
            Set rFind = Columns(3).FindNext(rFind)
            If rFind Is Nothing Then Exit Do
          Loop Until rFind.Address = Adr1
      End If
    Next AC
 
    Application.StatusBar = Empty
    Application.ScreenUpdating = True
 
    MsgBox n & "  gefunden Daten"
End Sub

[Gast 123]

Hallo

Wow, was für ein Monstercode!!   Sorry, das ist bitte nicht als Beleidigung gedacht, aber für Programmierer echt beeindruckend!!
Er zeigt mir wie wichtig die fundamentalen Kenntnisse über gutes VBA sind, um auf die vielen Select Anweisungen zu verzichten!
Der Bildschirm dürfte vor Erregung so bunt flackern wie der Nachthimmel beim Feuerwerk zur Neujahrszeit! Spassig gemeint ...
 
Kommen wir zum besseren Programmieren. Mit 25 Jahre Erfahrung verlor ich nach zwei Minuten die Übersicht was der Code überhaupt macht!!
Ich ahne das du eine Tabelle jedesmal komplett neu aufbaust, und gebe dir dazu mal meinen Rat. Ich bin dazu viel zu faul, aber auf meine Art schlau!

Erstelle dir bitte EINE Vorlage, die mit Überschriften, Spaltenbreite, Formeln usw. komplett so aufgebaut ist wie du sie brauchst. Lade dir Daten, die von extern kommen, in eine extra Tabelle. Dann kopiere dir die Daten aus dieser Tabelle dahin wo sie benötigt werden. Das ist m.E. einfacher als jedesmal die Tabelle komplett neu einzurichten!

Schachtelmakro:   Zerlege dir Monsteraufgaben in einzelne kleine Makros, die du nacheinander aufrufst. Das erleichtert die die Übersicht. Vor allem kannst du jedes kleinere Makro testen bis es einwandfrei funktioniert, und weisst, das ist Okay, die Arbeit ist erledigt! Dann kombiniere sie. Ein grosser Vorteil ist, das man z.B. Sortierprograme zwei dreimal im Hauptprogramm aufrufen kann.

Sub Hauptprogramm
   Call Makro1   ein Makro nur zum sortieren, ein Makro nur zum kopieren, ein Makro für Splatenbreite und Schrift einrichten, usw.
   Call Makro2   usw.  beliebig viele  Auch (wiederholte) Auswahl einzelner Makros mit İF Then im Hauptprogramm möglich
End sub

Zum eigentlichen Problem:  Mein Makro sucht die letzte Zeile mit lz1 und lz2 in Spalte 3 + 12.  Evtl. musst du diese Spalte aendern? Du kannst dir lz1 + lz2 mit eine MsgBox zum testen anzeigen lassen, bevor das Makro startet. So finden wir heraus woran der Fehler liegt.  Anbei dein Code zum Teil bereinigt zurück. Wenn du verstanden hast wie man auf Select verzichten kann ist es kein Problem den Code bedeutend zu kürzen. Ich rate trotzdem dazu das lange Makro in mehrere Abschnitte zu teilen. Es wird dann einfach übersichlicher!!

mfg Gast 123

Code:

Sub Tabelle()
Dim lzSort As Long    'LastZell Sortierbereich
' Tabelle Makro
' Tabelle TS2021
'
' Tastenkombination: Strg+a
'
With ActiveWorkbook.Worksheets("SQLiteAdmin")
    lzSort = .Cells(Rows.Count, 1).End(xlUp).Row
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:=Range("D1:D" & lzSort), SortOn:= _
      xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("A1:AE" & lzSort)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With

    'Letzte Zeile an 1. St3elle kopieren??
    '**  Wozu ist das gut??  ist 11078 iööer die letzte Zeile??
    '** Rows(lzSort).Copy   erfasst immer die letzte Zeile
    Rows("11078:11078").Copy
    Rows("1:1").Insert Shift:=xlDown
   
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
   
    Columns("D:F").Delete Shift:=xlToLeft
    Columns("H:H").Delete Shift:=xlToLeft
   
    Windows("Strecken.xls").Columns("A:B").Copy _
    Windows("Aufgaben.xls").Columns("L:M")  'Ohne Paste!!
   
    Columns("O:AA").Delete Shift:=xlToLeft
   
    With Columns("A:M").Font
        .Color = -16727809
        .TintAndShade = 0
    End With
    With Columns("A:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 4.99893185216834E-02
        .PatternTintAndShade = 0
    End With
   
    Columns("N:M").Delete Shift:=xlToLeft
   
    Columns("C:C").Cut
    Columns("B:B").Insert Shift:=xlToRight
   
    Columns("G:G").Cut
    Columns("F:F").Insert Shift:=xlToRight
   
    Columns("J:J").Cut
    Columns("I:I").Insert Shift:=xlToRight
   
    Columns("A:A").ClearContents
    Range("A2").FormulaR1C1 = "=TEXT(ROW(R[-1]C),""00000"")"
    Range("A2").AutoFill Destination:=Range("A2:A11079")
'bitte selbst weitermachen!!
    Range("A2:A11079").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "'Nr."
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "'Szenario Name :"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "'Strecke :"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "'Beschreibung :"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "'Aufgabe :"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "'Startzeit :"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "'S"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "'Spielerfahrzeug :"
   
    With Range("A1:F1").Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("K1").Select
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("G1:J1").Select
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Wide Latin"
        .Size = 6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
   
    Columns("A:A").ColumnWidth = 5
    Columns("B:B").ColumnWidth = 50
    Columns("C:C").Select
    Selection.ColumnWidth = 45
    Columns("D:D").Select
    Selection.ColumnWidth = 82
    Columns("E:E").Select
    Selection.ColumnWidth = 19
   
    Range("F1").FormulaR1C1 = "'min."
    With Range("F1").Characters(Start:=1, Length:=0).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=4, Length:=1).Font
        .Name = "Wide Latin"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16727809
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
   
    Range("E1").FormulaR1C1 = "'Aufgabe :"
    Columns("E:E").ColumnWidth = 19
    Columns("F:F").Select
    Selection.ColumnWidth = 3
    Columns("G:G").Select
    Selection.ColumnWidth = 5
    Columns("H:H").Select
    Selection.ColumnWidth = 7
    Columns("I:I").Select
    Selection.ColumnWidth = 8
    Columns("J:J").Select
    Selection.ColumnWidth = 1
    Columns("K:K").Select
    Selection.ColumnWidth = 38
    ActiveWindow.DisplayHeadings = False
   
    '** hier mein Makro als 2. Makro aufrufen
    Call Name_von_Makro_Gast
End Sub



Sub Name_von_Makro_Gast()
    Dim rFind As Range, lz2 As Long
    Dim Adr1 As Variant, n As Long
    Adr1 = Right(Range("C2"), 4)
    'Prüfen ob Makro ausgeführt wurde!
    If Not IsNumeric(Adr1) Then
      MsgBox "In Zelle C1 steht bereits Text! - Abbruch!": Exit Sub
    End If

    '** LastZell in Spalte -K- suchen
    lz1 = Cells(Rows.Count, 12).End(xlUp).Row
    lz2 = Cells(Rows.Count, 3).End(xlUp).Row
    'kopiere Spalte C nach Spalte N    (Sicherheits Kopie)
    Range("C2:C" & lz2).Copy
    Range("N2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

    'Suche RoutenNummer in Spalte C
    For Each AC In Range("L2:L" & lz1)
      Application.StatusBar = AC.Row & "  /  " & lz1 & "  /  " & n
      Set rFind = Columns(3).Find(What:=AC, After:=[c1], LookIn:=xlFormulas, LookAt:= _
          xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

      If Not rFind Is Nothing Then
          Adr1 = rFind.Address
          Do
            n = n + 1  'gedunden Daten zaehlen
            'Text aus Spalte B nach D ausgeben
              rFind.Value = AC.Offset(0, 1)
            'weitersuchen (falls mehrfach vorhanden)
            Set rFind = Columns(3).FindNext(rFind)
            If rFind Is Nothing Then Exit Do
          Loop Until rFind.Address = Adr1
      End If
    Next AC

    Application.StatusBar = Empty
    Application.ScreenUpdating = True

    MsgBox n & "  gefunden Daten"
End Sub

[RoAdRuNnEr]

Als ich Dein verändertes Makro sah, hab ich gleich gewußt das es eigentlich so funktionieren müsste, aber nach ausführung bekam ich einen Fehler angezeigt :

Windows("Strecken.xls").Columns("A:B").Copy _
Windows("Aufgaben.xls").Columns("L:M")  'Ohne Paste!!

wieso ohne Paste?  
Ich möchte lediglich von einer anderen Tabelle (Strecken.xls) die Spalte A und B in der Tabelle Aufgaben.xls in Spalte L und M kopieren.
Was ist daran Falsch ?

Was die letzte Zeile betrifft und warum diese nach ganz oben kopiert werden soll...es ist die Eigentliche Überschriftsspalte.
Das Dumme daran ist, selbst wenn ich diese vorher fixiere und dann die ganze Spalte D auswähle um sie Alphabetisch zu sortieren, wird die
Überschriftszeile dennoch mit Alphabetisch sortiert (so wie auch die Nachbarspalten nach Anfrage von Excel sortiert werden) was ja auch Richtig ist,
da sich die ganze Tablle Alphabetisch nach Spalte D ausrichten soll, jedoch ist es so, daß die Eigentliche Überschriftenzeile sich mit in das Alphabet einsortiert
und in dem Falle sich in die letzte Zeile verirrt da die Spalte D nur Zahlen betrifft und die Überschriftsspalte mit Buchstaben versehen ist.
Deshalb muß ich erneut die Überschriftspalte von der letzten,-zur ersten Zeile zurück katapultieren....hehe
Du hast bestimmt Recht mit dem was Du gesagt hast in Sachen eigene Tabelle erstellen und die Daten Einfach aus der Standart Tabelle in den entsprechenden Spalten reinkopieren, jedoch habe ich es erst mal so gelernt und bin Froh das erst mal bis auf weiteres so (Natürlich nur mit Deiner Hilfe) hinbekommen zu haben.
Wenn ich jetzt Nochmal anfange alles umzustricken und sogar noch kleine Einzelne Makros zu bauen die nur kleine Sachen machen, dann Blick ich da bald nicht mehr durch.  
Es wäre mir lieber, wenn ich nur 1 Makro ausführen müsste, wo schon alles drinne ist um die Tabelle dann auf meine Wünsche zurechtzubiegen.

Was noch zu ändern ware, ist die Auzählung die immer noch bei 11078 endet :

Range("A2").FormulaR1C1 = "=TEXT(ROW(R[-1]C),""00000"")"
Range("A2").AutoFill Destination:=Range("A2:A11078") <--- also immer wider bis ans Tabellenende durchnummeriert eventuell mit ("A2:A") ?
Diese müsste auch immer bis zum Ende der Tabelle gehen, weil wegen neuen Zeilen die in der Standart Tabelle dazu gekommen sind.


Meine Vorgehensweise ist immer die gleiche...
Ich lade die Strecken.xls und die Aufgaben.xls.
Dann führe ich das Makro aus und Speichere die neue Tabelle in Aufgaben.xls wieder ab.
Das Problem was ich habe ist , daß ich (wegen Unkenntnis) immer wieder Umständlich erst das Makro erst Einmal wieder reinladen muß (was ich gesondert vorher abgespeichert habe (Tabelle.bas)
und dieses erst mal in VisualBasic reinladen muß (importieren), um dann erst mal das Makro überhaupt starten zu können. Das ist Doof :(
Wäre es mal Möglich in Kontakt zu treten, um Dir mein vorgehen Live zu zeigen? Du hast bestimmt noch bessere Ideen dieses umzusetzen.

Edit : Die letzte Zeile (zeile der Überschriften) ist nicht immer die Zeile 11078, sondern immer die allerletzte Zeile der Tabelle.
Da sich die Standart Tablle immer wieder vergrößert, ist die Überschriftenzeile (nach Alphabetischer sortierung Natürlich immer an letzter Position und auf einer anderen Zeilennummer.

[schauan]

Hallöchen,

nur mal kurz zu

Windows("Strecken.xls").Columns("A:B").Copy _
Windows("Aufgaben.xls").Columns("L:M") 'Ohne Paste!!

wieso ohne Paste?

Im Prinzip ist das die "einzeilige" Ausführung des Kopierens eines Bereiches. Vollständig ausgeschrieben wäre es so:

Quellbereich.Copy Destination:=Zielbereich

Wobei man Destination:= weglassen kann.

"_" verbindet hier in der Ausführung zwei aufeinanderfolgende Zeilen zu einer. Ohne das "_" wäre die Paste in der zweiten Zeile erforderlich.

Quellbereich.Copy
Zielbereich.Paste