Bestimmten Bereich auf versch Werte durchsuchen

Hallo,
mir wurde hier schonmal exzellent geholfen, daher richte ich erneut eine Anfrage an die Profis hier, in der Hoffnung dass mir wieder geholfen werden kann.
Ich habe ein Sheet, in dem in den Spalten A - K verschiedenste Werte (numerisch und alphanumerisch) existieren. Die Anzahl der Zeilen ist unterschiedlich (ändert sich täglich). Nun möchte ich folgendes erreichen: In Spalte A gibt es einen bestimmten Begriff, der dort öfter auftaucht. Nun soll nach diesem Begriff gesucht werden, und der Bereich wo der Begriff das erste Mal auftaucht bis dorthin wo er zum zweiten Mal auftaucht, erweitert bis Spalte K markiert werden. In diesem markierten Bereich soll wiederum nach einem anderen Begriff (bzw zwei anderen) gesucht werden. Der erste gesuchte Begriff kann sich wiederholen, hierbei benötige ich aber nur den letzten im markierten Bereich gefundenen. In der Zelle neben diesem Begriff befindet sich ein Wert, dieser soll kopiert werden und in einem neuen Sheet in Zelle A1 eingetragen werden.
Beim zweiten gesuchten Begriff steht ebenfalls in der Zelle nebendran ein Wert, dieser kann positiv oder negativ sein, und kann auch in der Summe unterschiedlich sein (d.h. der Begriff kann auch mehrmals auftauchen)!! Sollte der Begriff gefunden werden und der Wert bzw die Summe der Werte positiv sein, soll im neuen Sheet in Zelle A2 ein "p" eingetragen werden. Ist der Wert oder die Summe 0 dann soll dort ein "g" eingetragen werden. Es ist auch möglich dass der Suchbegriff dort garnicht auftaucht, dann soll ebenfalls ein "g" eingetragen werden.
Das ganze soll sich bis zum Ende der gesamten Tabelle fortführen.
Ich weiss nicht, ob das ohne Beispieldatei zu lösen ist....ich könnte später ein Beispiel hochladen und das ganze damit anschaulicher machen. Aber vielleicht wisst ihr ja ungefähr was ich meine und könnt schonmal etwas damit anfangen.
Bisher müssen wir täglich die Daten von Hand raussuchen und eintragen und das ist mit enorm viel Zeitaufwand verbunden....ich hoffe ihr könnt mir helfen, dabei viel viel kostbare Arbeitszeit einzusparen.
Vielen Dank im Voraus,
Kai

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Auswerten() Dim wksNeu As Worksheet, wksData As Worksheet Dim varA, varWert1, varWert2, dblSumme, strErgebnis As String Dim rngBereichA As Range, strAddress1 As String, rngSuchA As Range Dim Zeile1 As Long, Zeile2 As Long Dim rngSuch1 As Range Dim rngBereich As Range, rngSuch2 As Range, strAddress2 As String varA = Application.InputBox(Prompt:="Suchbegriff in Spalte A", Title:="Auswertung", _ Default:="WW", Type:=2) If varA = False Then Exit Sub varWert1 = Application.InputBox(Prompt:="1. Suchbegriff ", Title:="Auswertung", _ Default:="X", Type:=2) If varWert1 = False Then Exit Sub varWert2 = Application.InputBox(Prompt:="2. Suchbegriff ", Title:="Auswertung", _ Default:="Y", Type:=2) If varWert2 = False Then Exit Sub Set wksData = ActiveSheet With wksData Set rngBereichA = .Columns(1) 'nach 1. Fundstelle von Wert in Spalte A suchen Set rngSuchA = rngBereichA.Find(What:=varA, after:=.Cells(.Rows.Count, 1), _ LookIn:=xlValues, lookat:=xlWhole) If rngSuchA Is Nothing Then MsgBox "Suchbegriff """ & varA & """ nicht gefunden" Else strAddress1 = rngSuchA.Address '1. Fundstelle merken Do Zeile1 = rngSuchA.Row 'nächsten Treffer in Spalte A suchen Set rngSuchA = rngBereichA.Find(What:=varA, after:=rngSuchA, _ LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext) If rngSuchA.Address = strAddress1 Then Exit Do Zeile2 = rngSuchA.Row 'Suchbereich Spalten A:K Set rngBereich = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 11)) With rngBereich 'nach letztem wert1 suchen (in Zeilen des Bereich A:K) Set rngSuch1 = .Find(What:=varWert1, after:=.Cells(1, 1), _ LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _ searchdirection:=xlPrevious) If rngSuch1 Is Nothing Then 'do nothing Else dblSumme = 0 strErgebnis = "g" 'Nach Wert2 suchen Set rngSuch2 = .Find(What:=varWert2, after:=.Cells(1, 1), _ LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _ searchdirection:=xlNext) If Not rngSuch2 Is Nothing Then strAddress2 = rngSuch2.Address 'Werte in Zellen rechts von Fundstellen aufsummieren Do dblSumme = dblSumme + rngSuch2.Offset(0, 1).Value Set rngSuch2 = .FindNext(after:=rngSuch2) If rngSuch2.Address = strAddress2 Then Exit Do Loop End If If dblSumme > 0 Then strErgebnis = "p" 'Neues Tabellenblatt anlegen With ActiveWorkbook .Worksheets.Add after:=.Sheets(.Sheets.Count) End With Set wksNeu = ActiveSheet wksNeu.Range("A1") = rngSuch1.Offset(0, 1).Value wksNeu.Range("A2") = strErgebnis End If End With Loop End If End With Beenden: Set wksNeu = Nothing: Set wksData = Nothing Set rngBereichA = Nothing: Set rngSuchA = Nothing Set rngBereich = Nothing: Set rngSuch1 = Nothing: Set rngSuch2 = Nothing End Sub

Hallo Kai,
hier das Makro mit den erforderlichen Anpassungen (Wert1 >=0, End of Report, alles in eine Liste).
Gruß
Franz

Sub Auswerten()
Dim wksNeu As Worksheet, wksData As Worksheet
Dim varA, varWert1, varWert2, dblSumme, strErgebnis As String
Dim rngBereichA As Range, strAddressA As String, rngSuchA As Range
Dim Zeile_N As Long, Zeile1 As Long, Zeile2 As Long
Dim rngSuch1 As Range, strAddress1 As String, varErgebnis1
Dim rngBereich As Range, rngSuch2 As Range, strAddress2 As String
varA = Application.InputBox(Prompt:="Suchbegriff in Spalte A", Title:="Auswertung", _
Default:="WW", Type:=2)
If varA = False Then Exit Sub
varWert1 = Application.InputBox(Prompt:="1. Suchbegriff ", Title:="Auswertung", _
Default:="X", Type:=2)
If varWert1 = False Then Exit Sub
varWert2 = Application.InputBox(Prompt:="2. Suchbegriff ", Title:="Auswertung", _
Default:="Y", Type:=2)
If varWert2 = False Then Exit Sub
With Application
.ScreenUpdating = False
End With
Set wksData = ActiveSheet
'Ergebnisblatt anlegen
With ActiveWorkbook
.Worksheets.Add after:=.Sheets(.Sheets.Count)
End With
Set wksNeu = ActiveSheet
Zeile_N = 1 'Startzeile für Einträge im neuen Blatt
With wksData
Set rngBereichA = .Columns(1)
'nach 1. Fundstelle von Wert in Spalte A suchen
Set rngSuchA = rngBereichA.Find(What:=varA, after:=.Cells(.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole)
If rngSuchA Is Nothing Then
MsgBox "Suchbegriff """ & varA & """ nicht gefunden"
Else
strAddressA = rngSuchA.Address '1. Fundstelle merken
Do
Zeile1 = rngSuchA.Row
'nächsten Treffer in Spalte A suchen
Set rngSuchA = rngBereichA.Find(What:=varA, after:=rngSuchA, _
LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
If rngSuchA.Address = strAddressA Then Exit Do
SucheBereich:
Zeile2 = rngSuchA.Row
'Suchbereich Spalten A:K
Set rngBereich = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 11))
With rngBereich
'nach letztem wert1 suchen (in Zeilen des Bereich A:K)
Set rngSuch1 = .Find(What:=varWert1, after:=.Cells(1, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If rngSuch1 Is Nothing Then
wksNeu.Cells(Zeile_N, 1) = 0
wksNeu.Cells(Zeile_N, 2) = "g"
Zeile_N = Zeile_N + 1
Else
varErgebnis1 = 0
strAddress1 = rngSuch1.Address
'Werte in Zellen rechts von Fundstellen prüfen, ob >0
Do
If rngSuch1.Offset(0, 1).Value > 0 Then
varErgebnis1 = rngSuch1.Offset(0, 1).Value
Exit Do
End If
Set rngSuch1 = .FindNext(after:=rngSuch1)
If rngSuch1.Address = strAddress1 Then Exit Do
Loop
dblSumme = 0
strErgebnis = "g"
'Nach Wert2 suchen
Set rngSuch2 = .Find(What:=varWert2, after:=.Cells(1, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext)
If Not rngSuch2 Is Nothing Then
strAddress2 = rngSuch2.Address
'Werte in Zellen rechts von Fundstellen aufsummieren
Do
dblSumme = dblSumme + rngSuch2.Offset(0, 1).Value
Set rngSuch2 = .FindNext(after:=rngSuch2)
If rngSuch2.Address = strAddress2 Then Exit Do
Loop
End If
If dblSumme > 0 Then strErgebnis = "p"
wksNeu.Cells(Zeile_N, 1) = varErgebnis1
wksNeu.Cells(Zeile_N, 2) = strErgebnis
Zeile_N = Zeile_N + 1
End If
If rngSuchA = "END OF REPORT" Then GoTo Beenden
End With
Loop
Zeile1 = Zeile2
Set rngSuchA = rngBereichA.Find(What:="END OF REPORT", after:=.Cells(Zeile1, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext)
If rngSuchA Is Nothing Then
MsgBox """END OF REPORT"" nicht gefunden!", vbInformation
Else
GoTo SucheBereich
End If
End If
End With
Beenden:
Set wksNeu = Nothing: Set wksData = Nothing
Set rngBereichA = Nothing: Set rngSuchA = Nothing
Set rngBereich = Nothing: Set rngSuch1 = Nothing: Set rngSuch2 = Nothing
With Application
.ScreenUpdating = True
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Bestimmten Bereich auf versch Werte durchsuchen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bestimmten Bereich auf versch Werte durchsuchen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread