Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1644to1648
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Filtern, sortieren, CopyPaste usw. PER MAKRO!

Filtern, sortieren, CopyPaste usw. PER MAKRO!
10.09.2018 09:02:48
Klaus
Guten Morgen liebe Profis
Ich kämpfe wiedereinmal seit geraumer Zeit mit einer "tollen Idee" von meinem Chef und komme einfach nicht auf die Lösung.
Ersteinmal hier die Beispieldatei: https://www.herber.de/bbs/user/123853.xlsx
Erklärung:
Im Blatt "data" werden manuell täglich aktuelle Abrufe aus einer anderen Tabelle eingefügt.
Im Blatt "Auswertung..." wird ein Suchergebniss ausgewertet. Z.B. wird in "data" nach einer Nummer (Spalte B) gesucht und gezählt. Spalte C gitb die Anzahl der gefundenen Nummer an, Spalte F ist ein aktueller Bestand, Spalte D die Differenz, usw...
(Blatt Auswertung ist eher unwichtig)
Was ich bzw. mein Chef nun benötigen:
1. Blatt "data" soll/muss gefiltert werden. Eine neu eingelesene Datei umfasst derzeit 5000 Zeilen mit vielen "unnötigen" Informationen. Der Filter soll, wenn eine neue Eingabe erfolgt alle Zeilen, in denen in Spalte U nichts steht löschen. (Das schrumpft die Menge schonmal um ca. 3000-3500 Zeilen!)
2. im Blatt "data" (Spalte U) soll nach den Nummern aus Blatt "Auswertung..." (Spalte B) gesucht werden. Wird eine Nummer gefunden soll die komplette Zeile in ein neues Blatt, dass als Namen die entsprechende Nummer hat fortlaufend eingefügt werden.
(Je Nummer ein neues Blatt. Wenn Nummer nicht gefunden, dann ignorieren/nichts tun)
3. (und wohl das schwierigste) In jedem neu erstellten Blatt muss nun sortiert werden nach Spalte R. Im Besten Fall ist der Liefertermin nun aufsteigend. Als letztes sollen im neuen Blatt (Bsp. 4100010224) fortlaufend die Zeilen gefärbt werden. Bedingung, im Blatt "Auswertung..." Spalte F stehende Zahl gibt an, wieviele Zeilen von oben grün gefärbt sein sollen (in dem Fall 5 Zeilen). Alles was darunter steht und gefüllt ist soll rot gefärbt werden.
4. Im Blatt "Auswertung..." ein Button, der das ganze Makro startet und einen 2. Button, mit dem ich nach getaner Arbeit, alle neu erstellten Blätter wieder löschen ("data" und "Auswertung..." müssen bleiben!) und den kompletten Inhalt aus Blatt "data" löschen kann.
Ich komme mitlerweile nicht einmal mehr auf die simpelsten Makro-Schnipsel hierfür. Habe mehrere Codes aus dem Forum hier probiert. Ansatzweise und mit einer Nummer funktionierten diese auch aber auf Grund der vielen (bis zu 50) Nummern, nach denen gesucht werden soll klappte dann nichts mehr.
Ich bitte (verzweifelt) um euer Hilfe und bin für alles dankbar, was ihr mir bietet.
Vielen, vielen Dank vorab :)

19
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Filtern, sortieren, CopyPaste usw. PER MAKRO!
10.09.2018 09:59:38
Werner
Hallo Klaus,
ist der Datenbestand im Blatt "data" konstant (hier meine ich nicht die Anzahl Zeilen)?
Beginnen die Daten immer in D1 und gehen immer bis AExxx ?
Hier mal ein Makro zum löschen der kompletten Zeilen bei denen in Spalte U kein Wert eingetragen ist.
Public Sub Leere_löschen()
Dim loLetzte As Long
Application.ScreenUpdating = False
With Worksheets("data")
loLetzte = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 32), .Cells(loLetzte, 32))
raBereich.FormulaLocal = "=WENN(U2="""";0;ZEILE())"
.Cells(1, 32) = 0
raBereich.Value = raBereich.Value
.Range(.Cells(1, 1), .Cells(loLetzte, 32)).RemoveDuplicates Columns:=32, Header:=xlNo
.Columns(32).ClearContents
End With
Application.ScreenUpdating = True
End Sub
Gruß Werner
Anzeige
AW: Filtern, sortieren, CopyPaste usw. PER MAKRO!
10.09.2018 10:22:14
Klaus
Hallo Werner
danke für das Makro zum löschen. Werden ich schonmal einfügen und abspeichern ;)
Ja, die Spalten so wie sie derzeit im "data" sind bleiben konstant (auch die ausgeblendeten).
Neue Daten werden immer ab D2 eingefügt. Lediglich der Inhalt der Zellen und die Zeilen nach unten ändern sich.
AW: Filtern, sortieren, CopyPaste usw. PER MAKRO!
10.09.2018 16:05:21
Werner
Hallo Klaus,
mußt dich noch etwas gedulden. Habs eigentlich fertig aber mein I-Net ist down. Sobald mein Provider das wieder auf die Reihe gekriegt hat stell ich den Code ein.
Gruß Werner
AW: Filtern, sortieren, CopyPaste usw. PER MAKRO!
10.09.2018 19:46:34
Werner
Hallo Klaus,
hier mal deine Beispielmappe zurück.
Ganz fertig ist das noch nicht.
Die Rotfärbung der Zeilen ist noch nicht drin.
Den Code zum Löschen der angelegten Tabellen und zum leeren des Blattes "data" habe ich auch noch nicht drin - das ist aber kein Problem.
Warum die Rotfärbung noch nicht:
Schau dir mal das Ergebnis nach Makrolauf in deiner Testdatei an. Da gibt es neu angelegte Blätter bei denen mehr Zeile grün gefärbt sind, als überhaupt Ergebniszeilen vorhanden sind - was dann?
https://www.herber.de/bbs/user/123869.xlsm
Der Button zum Makrostart ist im zweiten Blatt.
Gruß Werner
Anzeige
neue Version
10.09.2018 22:07:38
Werner
Hallo Klaus,
hier eine neue Version. Jetzt auch mit einem Button zum Löschen der Blätter und leeren des Blattes "data".
Zudem habe ich den vorherigen Code noch etwas gekürzt, da hatte ich etwas zu sehr um die Ecke gedacht.
Die Sache mit dem Rotfärben fehlt noch, da mir das noch unklar ist.
https://www.herber.de/bbs/user/123871.xlsm
Gruß Werner
AW: neue Version
11.09.2018 06:18:02
Klaus
Guten Morgen Werner
vorab ein riesen Dankeschön für deine Mühe und meinen vollen Respekt für deine Arbeit!
Auch wenn ich nur kurz über deinen Code geflogen bin weiß ich jetzt schon, dass ich das nie im Leben selbst hinbekommen hätte.
Ich schaue später gemeinsam mit meinem Chef nocheinmal genauer hin und versuche auch, deinen Gedankengang nachzuvollziehen sowie den Code zu verstehen.
Bezüglich der Färbung:
Hintergund bzw. Sinn ist einfach nur, dass der Wert, der im Blatt "Auswertung..." ausgelesen wird einen derzeitigen Lagerbestand der Nummer angibt. Grüne Färbung, wenn wir den Abruf mit diesem Lagerbestand abdecken können. Sind allerdings mehr Abrufe dieser Nummer vorhanden als wir im Lager haben soll ab Lagerbestand 0 die Zeile rot gefärbt werden. Anhand der Spalte "Lieferdatum" sehen wir dann, zu wann die Nummer ins Lager geliefert werden muss. (dies nur als Hintergrundinfo)
Zu deiner Frage:
Sollte im Blatt "data" Nummer 1234 z.B. 20 mal gefunden werden, der Lagerbestand im Blatt "Auswertung..." sagt 30 mal da sollte das Makro zur färbung bei der letzten gefüllten Zeile stoppen. Spätestens bei der nächsten Einlesung neuer Daten in "data" würde der Bestand ja nicht mehr ausreichen und die verschieden Färbung greift wieder (*denk*).
Anzeige
AW: neue Version
11.09.2018 07:28:34
Klaus
Einfach der Wahnsinn!!!
Makro(s) getestet und versucht zu verstehen. Ich bzw. wir sind total sprachlos und beeindruckt!
Es funktioniert alles genau so, wie es soll und das in einem so übersichtlichen und "kleinen" Code.
Klasse Arbeit Werner!
2 Kleinigkeiten hätte ich aber noch, wenn es nicht zu viel Aufwand bedeutet.
1.Im Blatt "Auswertung..." wurde eine Spalte geändert ("E"). Hier sollte, wenn möglich, je Nummer das Datum (Spalte R) der ersten, nicht gefärbten bzw. rot gefärbten Zeile eingetragen werden.
In der Beispieldatei z.B.
Nummer 4100010224 (Blatt) erste, nicht gefärbte Zeile, Spalte R(31.08.2018), copypaste in Blatt "Auswertung..." E2
2. Ein etwas dunkleres Grün xD in den neu angelegten Blättern. Ich habe zwar die Zeile im Code gefunden, kann auch auf rot, blau, gelb etc. ändern nur die dunkleren Farbtöne akzeptiert er nicht :/
Hier die angepasste Testdatei: https://www.herber.de/bbs/user/123874.xlsm
Erneut herzlichen Dank für deine Mühe und ein riesen Lob an dich !!!
Anzeige
Nachfrage
11.09.2018 09:36:26
Werner
Hallo Klaus,
heute vormittag komme ich da nicht mehr dazu und heute nachmittag bin ich arbeiten. Kann dir also nicht verprechen, ob das heute noch was wird. Du mußt dich also vielleicht ein zwei Tage gedulden. Scheint mir aber grundsätzlich machbar.
Was du willst ist mir klar. Aber dazu ein paar Fragen:
-im Blatt Auswertung.. Spalte E soll dieses Datum eingetragen werden?
-in Spalte E (Auswertung...) steht eine Zahl für Gesamtbedarf (Formel) -einfach überschreiben?
-auch hier die Frage: wenn es im neu angelegten Blatt zur Nummer nur "grüne Zeilen" gibt und keine "roten" was dann?
Die Frage zur Rotfärbung ist auch noch unklar.
-kann es nicht vorkommen, dass im neu angelegten Blatt der Nummer weniger Datensätze entstehen als die angegebene Zahl in Spalte F vorgibt?
-wenn es vorkommen kann was dann?
Beispiel:
Nummer: 4100010225
Im Blatt 4100010225 kommen als Ergebnis nur 10 Datensätze an
Im Blatt Auswertung.. Spalte F steht aber 20
Im Moment würden die Zeilen der 10 Datensätze grün gefärbt und zusätzlich die folgenden 10 Leerzeilen auch.
Sollen dann nur die tatsächlichen Datensätze grün gefärbt werden?
Soll dann kein Datum im Blatt Auswertung.. Spalte E der Nummer 4100010225 eingetragen werden?
Gruß Werner
Anzeige
AW: Nachfrage
11.09.2018 10:08:44
Klaus
Hallo Werner.
heute vormittag komme ich da nicht mehr dazu und heute nachmittag bin ich arbeiten. Kann dir also nicht verprechen, ob das heute noch was wird. Du mußt dich also vielleicht ein zwei Tage gedulden.
Keinen Stress bitte! Die Tabelle erfüllt ja jetzt schon seinen Zweck. Mein Nachtrag ist ja eher ein "Nice-to-have"-Zusatz. Auf ein paar Tage kommt es also nicht an ;-)
-im Blatt Auswertung.. Spalte E soll dieses Datum eingetragen werden?
-in Spalte E (Auswertung...) steht eine Zahl für Gesamtbedarf (Formel) -einfach überschreiben?
-auch hier die Frage: wenn es im neu angelegten Blatt zur Nummer nur "grüne Zeilen" gibt und keine "roten" was dann

In der von mir im letzten Beitrag hochgeladenen Datei ist Spalte E eig. leer. (E1 = offene PNR)
Sicherlich nutzt du noch die 1. Datei. Hier kannst du in Spalte E aber alle Formeln und Werte löschen. Diese Spalte ist unwichtig für unsere Zwecke.
Wenn im neu angelegten Blatt nur "grüne Zeilen" sind dann bleibt die Zelle in "Auswertung..." Spalte E leer. (z.B. Wenn "4100010225" gefüllte Zeilen kleiner oder gleich "Auswertung..." F3 dann "Auswertung" E3 leer")
In den neu angelegten Blättern je Nummer sollen nur Zeilen mit Inhalt gefärbt werden (entweder grün oder rot). Ist eine Zeile leer = keine Füllung, egal welcher Wert in Spalte F steht.
Vlt ist es auch leichter oder sinnvoller, wenn nicht die ganze Zeile entsprechend gefärbt wird sondern nur Spalte C (in den neu angelegten Blättern). Dann wäre das "grelle Grün" auch nicht weiter schlimm. Das aber überlasse ich dir.
Ist wie erwähnt nur ein Zusatz, der uns gefallen würde und die Übersichtlichkeit für uns erleichtern soll.
Gruß Klaus
Anzeige
AW: Nachfrage
12.09.2018 13:51:26
Werner
Hallo Klaus,
hier jetzt der Code mit Rot/Grün Färbung und Übertrag des Datums.
Sind weniger Treffer vorhanden als im Blatt Auswertung.. Spalte F als zu färbend angegeben, dann werden nur die tatsächlich vorhandenen Treffer gefärbt.
Die Farben habe ich jetzt mal geändert, damit du keinen Augenkrebs bekommst.
Im Code sind jetzt einige Zeilenumbrüche drin, die eigentlich nicht nögig sind. Die habe ich rein gemacht, weil sonst die Forensoftware die Zeilen willkürlich umbricht.
Das kannst du so lassen oder wieder raus machen.
Option Explicit
Public Sub Daten_aufbereiten()
Dim loLetzteData As Long, loLetzteAus As Long, i As Long, x As Long
Dim raBereich As Range, raZelle As Range, raFund As Range
Dim arrZeichnung(), arrAnzahl(), strFirstAddress As String
If Worksheets("data").Range("D2") = "" Then
MsgBox "Es sind keine Daten vorhanden."
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("data")
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 32), .Cells(loLetzteData, 32))
raBereich.FormulaLocal = "=WENN(U2="""";0;ZEILE())"
.Cells(1, 32) = 0
raBereich.Value = raBereich.Value
.Range(.Cells(1, 1), .Cells(loLetzteData, 32)).RemoveDuplicates Columns:=32, _
Header:=xlNo
.Columns(32).ClearContents
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
End With
With Worksheets("Auswertung EHG")
loLetzteAus = .Cells(.Rows.Count, 2).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 2), .Cells(loLetzteAus, 2))
For Each raZelle In raBereich
If raZelle.Offset(, 1) > 0 Then
If WorksheetFunction.Count(raZelle.Value, Worksheets("data") _
.Range("U2:U" & loLetzteAus)) > 0 Then
ReDim Preserve arrZeichnung(i)
ReDim Preserve arrAnzahl(i)
arrZeichnung(i) = raZelle.Value
arrAnzahl(i) = raZelle.Offset(0, 4).Value
i = i + 1
End If
End If
Next raZelle
End With
For i = 0 To UBound(arrZeichnung)
Worksheets.Add after:=ThisWorkbook.Worksheets(Sheets.Count)
ActiveSheet.Name = arrZeichnung(i)
With Worksheets("data")
Set raFund = .Range("U2:U" & loLetzteData).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not raFund Is Nothing Then
x = 1
strFirstAddress = raFund.Address
Do
.Rows(raFund.Row).Copy
Worksheets(CStr(arrZeichnung(i))).Range("A" & x).PasteSpecial _
Paste:=xlPasteValues
x = x + 1
Set raFund = .Range("U2:U" & loLetzteData).FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirstAddress
With Worksheets(CStr(arrZeichnung(i)))
.Columns("D:AE").AutoFit
.Columns("R:R").NumberFormat = "m/d/yyyy"
.Columns("S:S").NumberFormat = "hh:mm:ss"
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("R1:R" & x), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:AE" & x)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
If x - 1 > arrAnzahl(i) Then
.Range(.Cells(1, 4), .Cells(arrAnzahl(i), 31)) _
.Interior.Color = 6736896
.Range(.Cells(arrAnzahl(i) + 1, 4), .Cells(x - 1, 31)) _
.Interior.Color = 26367
With Worksheets("Auswertung EHG")
Set raFund = .Columns(2).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
End With
Worksheets("Auswertung EHG").Cells(raFund.Row, 5) = _
.Cells(arrAnzahl(i) + 1, 18)
Else
.Range(.Cells(1, 4), .Cells(x - 1, 31)).Interior.Color = 6736896
End If
End With
End If
End With
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Gruß Werner
Anzeige
AW: Nachfrage
12.09.2018 14:40:16
Klaus
Hallo Werner,
was soll ich sagen außer vielen, herzlichen Dank!
Super Arbeit, alles funktioniert wie es soll, einfach perfekt!
Ich habe gestern und heute noch ein wenig an dem vorherigen Code gebastelt und einige Sachen ergänzt (somit konnte ich auch deine Vorgehensweise analysieren und wieder etwas Neues lernen).
Meine Änderungen für die, die es interessiert:
1. Ich blende uninteressante Spalten nach dem Erstellen des neuen Blatt´s aus. (Bin der Meinung, dass hier die Geschwindigkeit etwas weniger leidet)
2. Habe ich "testweise" die Färbung nur auf Spalte C eingestellt anstatt alles zu färben.
3. Bleibt der Fokus auf dem Blatt "Auswertung EHG". Hier bin ich mir aber nicht sicher, ob diese Lösung so gut ist (rücksprungBlatt...). War das einzig, für mich verständliche, was ich hier im Forum gefunden habe. Eig. wollte ich, dass die Markierung der letzten Zeile in den neuen Blättern aufgehoben wird und automatisch wieder Blatt "Auswertung EHG" aktiviert wird aber beides zusammen wollte nicht klappen. Daher diese etwas unschöne Lösung.
Hier noch einmal zur Verständnis mein derzeitige benutzer Code in voller Länge:
Option Explicit
Public Sub Daten_aufbereiten()
Dim loLetzteData As Long, loLetzteAus As Long, i As Long, x As Long
Dim raBereich As Range, raZelle As Range, raFund As Range
Dim arrZeichnung(), arrAnzahl(), strFirstAddress As String
Dim rücksprungBlatt As Worksheet
Set rücksprungBlatt = ActiveSheet
If Worksheets("data").Range("D2") = "" Then
MsgBox "Es sind keine Daten vorhanden."
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("data")
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 32), .Cells(loLetzteData, 32))
raBereich.FormulaLocal = "=WENN(U2="""";0;ZEILE())"
.Cells(1, 32) = 0
raBereich.Value = raBereich.Value
.Range(.Cells(1, 1), .Cells(loLetzteData, 32)).RemoveDuplicates Columns:=32, _
Header:=xlNo
.Columns(32).ClearContents
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
End With
With Worksheets("Auswertung EHG")
loLetzteAus = .Cells(.Rows.Count, 2).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 2), .Cells(loLetzteAus, 2))
For Each raZelle In raBereich
If raZelle.Offset(, 1) > 0 Then
If WorksheetFunction.Count(raZelle.Value, Worksheets("data") _
.Range("U2:U" & loLetzteAus)) > 0 Then
ReDim Preserve arrZeichnung(i)
ReDim Preserve arrAnzahl(i)
arrZeichnung(i) = raZelle.Value
arrAnzahl(i) = raZelle.Offset(0, 4).Value
i = i + 1
End If
End If
Next raZelle
End With
For i = 0 To UBound(arrZeichnung)
Worksheets.Add after:=ThisWorkbook.Worksheets(Sheets.Count)
ActiveSheet.Name = arrZeichnung(i)
With Worksheets("data")
Set raFund = .Range("U2:U" & loLetzteData).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not raFund Is Nothing Then
x = 1
strFirstAddress = raFund.Address
Do
.Rows(raFund.Row).Copy
Worksheets(CStr(arrZeichnung(i))).Range("A" & x).PasteSpecial _
Paste:=xlPasteValues
x = x + 1
Set raFund = .Range("U2:U" & loLetzteData).FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirstAddress
With Worksheets(CStr(arrZeichnung(i)))
.Columns("D:AE").AutoFit
.Columns("R:R").NumberFormat = "m/d/yyyy"
.Columns("S:S").NumberFormat = "hh:mm:ss"
Range("A:B,D:H,J:Q,T:T,V:AE").EntireColumn.Hidden = True
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("R1:R" & x), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:AE" & x)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
If x - 1 > arrAnzahl(i) Then
.Range(.Cells(1, 3), .Cells(arrAnzahl(i), 3)) _
.Interior.Color = 6736896
.Range(.Cells(arrAnzahl(i) + 1, 3), .Cells(x - 1, 3)) _
.Interior.Color = 26367
With Worksheets("Auswertung EHG")
Set raFund = .Columns(2).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
End With
Worksheets("Auswertung EHG").Cells(raFund.Row, 5) = _
.Cells(arrAnzahl(i) + 1, 18)
Else
.Range(.Cells(1, 3), .Cells(x - 1, 3)).Interior.Color = 6736896
End If
End With
End If
End With
Next i
rücksprungBlatt.Activate
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Sub Löschen()
Dim ws As Worksheet
If MsgBox("Sollen die Blätter tatsächlich gelöscht werden?", vbYesNo, "Löschbestätigung") =  _
vbYes Then
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "data", "Auswertung EHG"
Case Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Select
Next ws
Worksheets("data").UsedRange.Offset(1).ClearContents
End If
End Sub
Zum Abschluss noch einmal, auch von meinem Chef, vielen, vielen Dank Werner! Auch wenn das für dich sicherlich keine große Sache ist, ist es für uns erstaunlich, was du (allg. hier im Forum) so leistest.
Danke und Gruß Klaus :)
Anzeige
Gerne u. Danke für die Rückmeldung und....
12.09.2018 15:10:23
Werner
Hallo Klaus,
...dazu brauchst du nicht extra ein Worksheetobjekt deklarieren und Set(zen).
Einfach:
Worksheets("Auswertung EHG").Activate
Gruß Werner
ich nochmal...
12.09.2018 15:44:46
Werner
Hallo Klaus,
hier der Code nochmal komplett. Jetzt werden die Markierungen der letzten Zeile in den neu erstellten Blättern aufgehoben und du bleibst auf deinem Auswertungsblatt.
Option Explicit
Public Sub Daten_aufbereiten()
Dim loLetzteData As Long, loLetzteAus As Long, i As Long, x As Long
Dim raBereich As Range, raZelle As Range, raFund As Range
Dim arrZeichnung(), arrAnzahl(), strFirstAddress As String
If Worksheets("data").Range("D2") = "" Then
MsgBox "Es sind keine Daten vorhanden."
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("data")
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 32), .Cells(loLetzteData, 32))
raBereich.FormulaLocal = "=WENN(U2="""";0;ZEILE())"
.Cells(1, 32) = 0
raBereich.Value = raBereich.Value
.Range(.Cells(1, 1), .Cells(loLetzteData, 32)).RemoveDuplicates Columns:=32, _
Header:=xlNo
.Columns(32).ClearContents
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
End With
With Worksheets("Auswertung EHG")
loLetzteAus = .Cells(.Rows.Count, 2).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 2), .Cells(loLetzteAus, 2))
For Each raZelle In raBereich
If raZelle.Offset(, 1) > 0 Then
If WorksheetFunction.Count(raZelle.Value, Worksheets("data") _
.Range("U2:U" & loLetzteAus)) > 0 Then
ReDim Preserve arrZeichnung(i)
ReDim Preserve arrAnzahl(i)
arrZeichnung(i) = raZelle.Value
arrAnzahl(i) = raZelle.Offset(0, 4).Value
i = i + 1
End If
End If
Next raZelle
End With
For i = 0 To UBound(arrZeichnung)
Worksheets.Add after:=ThisWorkbook.Worksheets(Sheets.Count)
ActiveSheet.Name = arrZeichnung(i)
With Worksheets("data")
Set raFund = .Range("U2:U" & loLetzteData).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not raFund Is Nothing Then
x = 1
strFirstAddress = raFund.Address
Do
.Rows(raFund.Row).Copy
Worksheets(CStr(arrZeichnung(i))).Range("A" & x).PasteSpecial _
Paste:=xlPasteValues
x = x + 1
Set raFund = .Range("U2:U" & loLetzteData).FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirstAddress
With Worksheets(CStr(arrZeichnung(i)))
.Columns("D:AE").AutoFit
.Columns("R:R").NumberFormat = "m/d/yyyy"
.Columns("S:S").NumberFormat = "hh:mm:ss"
.Range("A:B,D:H,J:Q,T:T,V:AE").EntireColumn.Hidden = True
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("R1:R" & x), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:AE" & x)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
If x - 1 > arrAnzahl(i) Then
.Range(.Cells(1, 4), .Cells(arrAnzahl(i), 31)) _
.Interior.Color = 6736896
.Range(.Cells(arrAnzahl(i) + 1, 4), .Cells(x - 1, 31)) _
.Interior.Color = 26367
With Worksheets("Auswertung EHG")
Set raFund = .Columns(2).Find(what:=arrZeichnung(i), _
LookIn:=xlValues, LookAt:=xlWhole)
End With
Worksheets("Auswertung EHG").Cells(raFund.Row, 5) = _
.Cells(arrAnzahl(i) + 1, 18)
Else
.Range(.Cells(1, 4), .Cells(x - 1, 31)).Interior.Color = 6736896
End If
.Range("C1").Select
End With
End If
End With
Next i
Worksheets("Auswertung EHG").Activate
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Gruß Werner
Anzeige
Und zum Schluss noch etwas gelernt ;)
13.09.2018 06:39:07
Klaus
Guten morgen Werner,
Abschließend nochmals vielen Dank!
Ich werde dieses Macro zu lernzwecken noch etwas zerpflücken und in den nächsten Tagen/Wochen einiges testen, um alles besser zu verstehen.
Deinen finalen Code haben wir so wie er ist in unsere Excel eingefügt und werden heute einen Echtzeittest damit machen. (In der Testmappe lief ja alles perfekt, also was soll schon schiefgehen :))
Eine ruhige Restwoche und ein erholsames Wochenende für dich! :)
Kannst mich ja...
13.09.2018 06:56:26
Werner
Hallo Klaus,
...auf dem Laufenden halten, ob und wie das in der "Arbeitsdatei" läuft.
Gruß Werner
AW: Info
13.09.2018 12:47:52
Klaus
So Werner,
Datei wurde ausgibig und "unter realen Bedingungen" gestestet, absichtlich Fehler eingebaut und die Datenmenge in "data" auf 10.000 hochgeschraubt ...
Funktion zu 100% gegeben. Alles läuft und macht, was es machen soll. Keinen einzigen Fehler gefunden :)
Super Arbeit und meine Vorstellung perfekt (und in kürzester Zeit) umgesetzt. Ich kann dich auch im Namen meines Chefs nur immer wieder Loben!
Vielen, vielen Dank :)
Neuer Code
14.09.2018 00:57:48
Werner
Hallo Klaus,
die Laufzeit des Makros hatte ich überhaupt nicht auf dem Schirm. Hab ja immer nur mit den Daten der Beispieldatei gearbeitet.
Hab das Makro jetzt mal mit über 10.000 Datensätzen in "data" laufen lassen. Durch die Schleifenlösung und das ständige kopieren von einzelnen Zeilen brauchte das bei mir etwa 35 Sekunden.
Hier mal ein Makro mit einem ganz anderen Ansatz. Ich nutze da den Autofilter. Das hat den riesen Vorteil, dass die entsprechenden Datensätze im Block und nicht einzeln kopiert werden.
Laufzeit bei über 10.000 Datensätzen 1-2 Sekunden.
Ausgiebig getestet habe ich aber nicht - müsste aber so passen.
Option Explicit
Public Sub Daten_aufbereiten()
Dim loLetzteData As Long, loLetzteAus As Long, loLetzteNeu As Long
Dim loAnzahl As Long, boVorhanden as Boolean
Dim raBereich As Range, raZelle As Range
If Worksheets("data").Range("D2") = "" Then
MsgBox "Es sind keine Daten vorhanden."
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("data")
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 32), .Cells(loLetzteData, 32))
raBereich.FormulaLocal = "=WENN(U2="""";0;ZEILE())"
.Cells(1, 32) = 0
raBereich.Value = raBereich.Value
.Range(.Cells(1, 1), .Cells(loLetzteData, 32)).RemoveDuplicates Columns:=32, _
Header:=xlNo
.Columns(32).ClearContents
loLetzteData = .Cells(.Rows.Count, 4).End(xlUp).Row
End With
With Worksheets("Auswertung EHG")
loLetzteAus = .Cells(.Rows.Count, 2).End(xlUp).Row
Set raBereich = .Range(.Cells(2, 2), .Cells(loLetzteAus, 2))
For Each raZelle In raBereich
If raZelle.Offset(, 1) > 0 Then
If WorksheetFunction.Count(raZelle.Value, Worksheets("data") _
.Range("U2:U" & loLetzteData)) > 0 Then
boVorhanden = True
loAnzahl = raZelle.Offset(, 4).Value
Worksheets.Add after:=ThisWorkbook.Worksheets(Sheets.Count)
ActiveSheet.Name = CStr(raZelle.Value)
With Worksheets("data")
.Range("$D$1:$AE$" & loLetzteData).AutoFilter Field:=18, _
Criteria1:=raZelle.Value
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).Copy
Worksheets(CStr(raZelle.Value)).Cells(1, 4).PasteSpecial _
Paste:=xlPasteValues
End With
With Worksheets(CStr(raZelle.Value))
loLetzteNeu = .Cells(.Rows.Count, 4).End(xlUp).Row
.Columns("D:AE").AutoFit
.Columns("R:R").NumberFormat = "m/d/yyyy"
.Columns("S:S").NumberFormat = "hh:mm:ss"
.Range("A:B,D:H,J:Q,T:T,V:AE").EntireColumn.Hidden = True
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("R1:R" & loLetzteNeu), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:AE" & loLetzteNeu)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
If loLetzteNeu > loAnzahl Then
.Range(.Cells(1, 4), .Cells(loAnzahl, 31)).Interior.Color = 6736896
.Range(.Cells(loAnzahl + 1, 4), .Cells(loLetzteNeu, 31)) _
.Interior.Color = 26367
raZelle.Offset(, 3) = .Cells(loAnzahl + 1, 18)
Else
.Range(.Cells(1, 4), .Cells(loLetzteNeu, 31)).Interior.Color = 6736896
End If
.Range("A1").Select
End With
End If
End If
Next raZelle
End With
If Not boVorhanden Then
MsgBox "Es gibt keine übereinstimmenden Zeichnungsnummern."
End If
Worksheets("data").AutoFilterMode = False
Worksheets("Auswertung EHG").Activate
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Und der Code ist auch noch kürzer.
Gruß Werner
AW: Schneller ist besser ...
14.09.2018 06:20:09
Klaus
Guten Morgen Werner,
gestört hat uns die "längere Wartezeit" nicht aber ist natürlich klasse, wenn es selbst bei 10.000 Sätzen so zügig durchläuft.
Hab es erneut getestet und natürlich, wie erwartet, fehlerfrei (und sehr, sehr schnell!).
Mittlerweile weiß ich garnicht mehr, wie ich dir noch danken soll ^^
Das Projekt scheint dir Spaß zu machen ;-)
Danke Werner!
Gruß Klaus
Gerne u. Danke für die Rückmeldung...
14.09.2018 12:33:25
Werner
Hallo Klaus,
...ist mehr, dass mich VBA generell Spaß macht. Will meinen Wissensstand verbessern.
Gruß Werner

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige