VBA: Durchsuchen nach Wert und kopieren von Inhalt

Moin zusammen,
bin mit meinen eingeschränkten Kenntnissen nicht weit gekommen und daher auf Hilfe angewiesen.
Im Grunde genommen soll in jedem Tabellenblatt (Eingang1, Eingang2 etc.) dieselbe Spalte E nach zwei Wörtern ("Medium" und "High") durchsucht werden. Bei einem Treffer sind vorher definierte Zellen (z. B. A3, B3 und C3) der betroffenen Zeile in das Tabellenblatt "Lösung" zu kopieren.
In den zu durchsuchenden Tabellenblättern soll die Abfrage der beiden Bedingungen nicht fortlaufend für die ganze Spalte E gelten, sondern partiell. Das heißt, mal soll die Abfrage der Bedingungen für Zeile 3 - 8 gelten und danach bei Zeile 17 - 21 fortgeführt werden etc.). Dieses Vorgehen soll auch für die Übrigen Tabellen (Eingang2 - 10) realisiert werden, jedoch auch mit unterschiedlichen Zeilen.
In der Lösungstabelle sollen die Zeilen fortlaufend und ohne Unterbrechung gelistet werden.
Danke schon Mal für die Zeit im Voraus!
Glückauf
Denis

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Auswertung() Dim ersterFund As String Dim letzteZeileL As Long Dim suchErgebnis As Object Dim wb As Workbook Dim wsE As Worksheet ' Eingangsblätter (nacheinander) Dim wsL As Worksheet ' Lösungsblatt Dim zeileE As Long Dim zeileL As Long Set wb = ThisWorkbook Set wsL = wb.Worksheets("Lösung") letzteZeileL = wsL.Cells(wsL.Rows.Count, "A").End(xlUp).Row If letzteZeileL > 1 Then wsL.Rows(2).Resize(letzteZeileL - 1).ClearContents End If zeileL = 2 For Each wsE In wb.Worksheets If Left$(UCase$(wsE.Name), 7) = "EINGANG" Then Set suchErgebnis = wsE.Columns("A").Find(What:="ID No.", _ LookAt:=xlWhole) If Not suchErgebnis Is Nothing Then ersterFund = suchErgebnis.Address Do zeileE = suchErgebnis.Row + 1 Do Until IsEmpty(wsE.Cells(zeileE, "A")) If wsE.Cells(zeileE, "E") = "high" Or _ wsE.Cells(zeileE, "E") = "medium" Then wsL.Cells(zeileL, "A") = wsE.Name wsL.Cells(zeileL, "B") = wsE.Cells(zeileE, "A") ' Id No. wsL.Cells(zeileL, "C") = wsE.Cells(zeileE, "B") ' Question wsL.Cells(zeileL, "D") = wsE.Cells(zeileE, "E") ' ? wsL.Cells(zeileL, "E") = wsE.Cells(zeileE, "C") ' Remark zeileL = zeileL + 1 End If zeileE = zeileE + 1 Loop Set suchErgebnis = wsE.Columns("A").FindNext(After:=suchErgebnis) Loop While Not suchErgebnis Is Nothing And suchErgebnis.Address ersterFund End If End If Next wsE End Sub

Hallo Denis,
du brauchst natürlich für diejenigen Tabellenblätter, die als Datenlieferanten dienen ein eindeutiges Kriterium. Schließlich hast du ja auch noch Hilfsblätter in deiner Arbeitsmappe.
Ich habe das Programm jetzt so abgeändert, dass alle Blätter genommen werden, bei denen in A2 der Text "ID No." und in B2 der Text "List of Questions" steht. Die Spalten, aus denen gelesen wird, habe ich ebenfalls geändert.
In deiner neuen Datei gibt es ja pro Blatt nur noch einen Fragenblock. Ich habe trotzdem die Do-Schleife mit FindNext gelassen. Sie funktioniert natürlich auch für den Fall mit nur einem Block und vielleicht kommen weitere Blöcke hinzu.

Sub Auswertung()
Dim ersterFund As String
Dim letztezeileS As Long
Dim suchErgebnis As Object
Dim wb As Workbook
Dim wsE As Worksheet ' Blätter mit Eingabedaten (nacheinander)
Dim wsS As Worksheet ' Blatt "Summary"
Dim zeileE As Long
Dim zeileS As Long
Set wb = ThisWorkbook
Set wsS = wb.Worksheets("Summary")
letztezeileS = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row
If letztezeileS > 1 Then
wsS.Rows(2).Resize(letztezeileS - 1).ClearContents
End If
zeileS = 2
For Each wsE In wb.Worksheets
If wsE.Range("A2") = "ID No." And _
wsE.Range("B2") = "List of Questions" Then
Set suchErgebnis = wsE.Columns("A").Find(What:="ID No.", _
LookAt:=xlWhole)
If Not suchErgebnis Is Nothing Then
ersterFund = suchErgebnis.Address
Do
zeileE = suchErgebnis.Row + 1
Do Until IsEmpty(wsE.Cells(zeileE, "A"))
If wsE.Cells(zeileE, "P") = "high" Or _
wsE.Cells(zeileE, "P") = "medium" Then
wsS.Cells(zeileS, "A") = wsE.Name
wsS.Cells(zeileS, "B") = wsE.Cells(zeileE, "A") ' Id No.
wsS.Cells(zeileS, "C") = wsE.Cells(zeileE, "B") ' Question
wsS.Cells(zeileS, "D") = wsE.Cells(zeileE, "P") ' Benchmark
wsS.Cells(zeileS, "E") = wsE.Cells(zeileE, "M") ' Remark
zeileS = zeileS + 1
End If
zeileE = zeileE + 1
Loop
Set suchErgebnis = wsE.Columns("A").FindNext(After:=suchErgebnis)
Loop While Not suchErgebnis Is Nothing And suchErgebnis.Address  ersterFund
End If
End If
Next wsE
End Sub

https://www.herber.de/bbs/user/130961.xlsm
Viele Grüße
Dieter

Beliebteste Forumthreads (12 Monate)

VBA: Durchsuchen nach Wert und kopieren von Inhalt

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

335 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Durchsuchen nach Wert und kopieren von Inhalt

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

335 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread