Registriert seit: 19.02.2021
Version(en): 2019
25.02.2021, 10:50
(Dieser Beitrag wurde zuletzt bearbeitet: 25.02.2021, 10:57 von 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.
Registriert seit: 19.02.2021
Version(en): 2019
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.
Registriert seit: 18.06.2017
Version(en): 2021
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
Registriert seit: 19.02.2021
Version(en): 2019
27.02.2021, 10:23
(Dieser Beitrag wurde zuletzt bearbeitet: 27.02.2021, 10:24 von 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.
Registriert seit: 12.03.2016
Version(en): Excel 2003
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
Registriert seit: 19.02.2021
Version(en): 2019
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 !
Registriert seit: 19.02.2021
Version(en): 2019
28.02.2021, 22:07
(Dieser Beitrag wurde zuletzt bearbeitet: 28.02.2021, 22:49 von 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
Registriert seit: 12.03.2016
Version(en): Excel 2003
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
Registriert seit: 19.02.2021
Version(en): 2019
01.03.2021, 13:16
(Dieser Beitrag wurde zuletzt bearbeitet: 01.03.2021, 13:24 von 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.
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Hallöchen,
nur mal kurz zu
Zitat: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
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
|
Suchen und ersetzen
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
