Hallo,
dann wird es nichts ohne eine Beispieldatei!
Ich häng' meine Beispieldatei an, damit Du siehst, dass es unter gegebenen Umständen funktioniert.
[
attachment=4294]
Fenneks Variante würde ich hier nicht nutzen.
Wenn dann würde die FindNext Methode in Frage kommen.
Hallo,
ok, hab die Beispielmappe gesehen, muss aber jetzt weg.
Meine Variante, so wie ich sie eingestellt habe, funktioniert nur, wenn die Daten als Liste ohne Leezeilen zu der Überschrift vorliegen.
Ich schau später noch einmal rein.
Danke das ist super nett !!
Hallo,
Schleifen?
Ist gibt zwei Arten von Schleifen:
For i = 1 to 12 : mach was : next i
Oder
For each ws in thisworkbook.sheets : mach was : next
Da die for...next -Schleife nicht funktioniert, must du sie durch die genannte for ... each - Schleife ersetzen. Als Zusatz ist notwendig:
If ws.name <> "Result" thenn
der Code
End if
Mfg
(22.02.2016, 16:15)Fennek schrieb: [ -> ]Hallo,
Schleifen?
Ist gibt zwei Arten von Schleifen:
For i = 1 to 12 : mach was : next i
Oder
For each ws in thisworkbook.sheets : mach was : next
Da die for...next -Schleife nicht funktioniert, must du sie durch die genannte for ... each - Schleife ersetzen. Als Zusatz ist notwendig:
If ws.name <> "Result" thenn
der Code
End if
Mfg
Kannst du mir den Code möglicherweise aktualisieren ? ;)
Hallo,
Nein, ich werde den Code nicht aktualisieren. Ich nutze ein Tablet für den Besuch hier im Forum, d.h. ich muss alle Code von Hand vom Pc übertragen.
Ich verstehe das Forum als Hilfe zur Selbsthilfe, etwas Eigenleistung zum Anpassen bzw debugging ist da meistens notwendig.
Ansonsten gibt es noch professionelle Excel-Entwickler, die gerne ein rund-um-sorglos-Paket erstellen.
Mfg
Hallo,
den von mir eingestellten Code "aktualisieren" mit folgendem austauschen.
Code:
Sub aktualisieren()
Dim i As Long
Dim lngA As Long, lngZ As Long
Dim lngL As Long
Dim strSuch As String
Sheets("Gesamtübersicht").Select 'falls mal versehentlich aus einer anderen Tabelle heraus aufgerufen wurde
strSuch = "prüfen" 'gesuchter Wert
Range("C1").CurrentRegion.Offset(1, 0).ClearContents
Range("AA1").CurrentRegion.Clear
lngZ = 2
Application.ScreenUpdating = False
For i = 1 To Sheets.Count
If Sheets(i).Name <> ActiveSheet.Name Then
With Sheets(i)
lngA = Application.CountIf(Sheets(i).Columns("E"), strSuch)
If lngA > 0 Then
Range("AA1") = Range("D1")
lngL = .Cells(.Rows.Count, 3).End(xlUp).Row
Range("AA2") = strSuch
.Range("C1:J" & lngL).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"AA1:AA2"), CopyToRange:=Range("AB1:AI1"), Unique:=False
Range("AB2:AI" & lngA + 1).Copy Range("B" & lngZ)
lngZ = lngZ + lngA
End If
End With
End If
Next i
Range("AA1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub
Es sollten keine Spaltenüberschriften gleich benannt sein.
Anbei Deine Beispieldatei mit dem angepasstem Code.
[
attachment=4295]
Hallo,
ich würde es so machen:
Code:
Option Explicit
Private Sub worksheet_activate()
Dim loA As Long
Dim loLetzte As Long
Dim loLetzte2 As Long
Dim rng As Range
Dim wks As Worksheet
loLetzte2 = 7
Set wks = Sheets("Gesamtübersicht")
wks.Range("C:J").Clear
Application.ScreenUpdating = False
For loA = 1 To Sheets.Count
If Sheets(loA).Name <> "Gesamtübersicht" Then
With Sheets(loA)
loLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
If loLetzte < 7 Then loLetzte = 7
Set rng = .Range("C7:J" & loLetzte)
rng.Copy wks.Cells(loLetzte2 + 1, 3)
loLetzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row
If loLetzte2 < 7 Then loLetzte2 = 7
End With
End If
Next
Set rng = wks.Range("C7:J" & loLetzte2)
Range("C8") = rng.Sort(Range("E8"), xlDescending, Range("c8"), , xlAscending)
With Range("E8:E9999")
.Value = .Value
End With
loLetzte2 = Cells(Rows.Count, 5).End(xlUp).Row + 1
Range("C" & loLetzte2 & ":J900000").Clear
Application.ScreenUpdating = True
End Sub
Hallo Edgar,
keine schlechte Idee aber
1. vielleicht wäre es sinnvoll, vorher mit Zählenwenn() zu prüfen, ob überhaupt ein Treffer zu erwarten ist,
2. sollte auch geprüft werden ob genügend Zeilen vorrätig sind.
Hallo atilla,
kann man machen:
Code:
Option Explicit
Private Sub worksheet_activate()
Dim loA As Long
Dim loLetzte As Long
Dim loletzte2 As Long
Dim rng As Range
Dim wks As Worksheet
loletzte2 = 7
Set wks = Sheets("Gesamtübersicht")
wks.Range("C:J").Clear
Application.ScreenUpdating = False
For loA = 1 To Sheets.Count
If Sheets(loA).Name <> "Gesamtübersicht" Then
If Application.WorksheetFunction.CountIf(Sheets(loA).Range("E:E"), "prüfen") <> 0 Then
With Sheets(loA)
loLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
If loLetzte < 7 Then loLetzte = 7
Set rng = .Range("C7:J" & loLetzte)
rng.Copy wks.Cells(loletzte2 + 1, 3)
loletzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row + 1
If loletzte2 < 7 Then loletzte2 = 7
If loletzte2 > 60000 Then
sortieren
loletzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row + 1
End If
End With
End If
End If
Next
sortieren
Application.ScreenUpdating = True
End Sub
Sub sortieren()
Dim wks As Worksheet
Dim rng As Range
Dim loLetzte As Long
Set wks = Sheets("Gesamtübersicht")
loLetzte = Cells(Rows.Count, 5).End(xlUp).Row
Set rng = wks.Range("C7:J" & loLetzte)
rng.Sort key1:=Range("E7"), order1:=xlDescending, key2:=Range("c7"), order2:=xlAscending
With Range("E7:E9999")
.Value = .Value
End With
loLetzte = Cells(Rows.Count, 5).End(xlUp).Row + 1
Range("C" & loLetzte & ":J900000").Clear
End Sub