Wert in mehreren Tabellen suchen

Thomas · 2017-08-02T20:34:43+00:00

Liebe Excelspezialisten! ich benötige bitte wieder eure Hilfe. Wie die Überschrift schon aussagt benötige ich einen Code, der in den Tabellen einer Excelarbeitsmappe nach einen Wert sucht. Die zu suchenden Werte befinden sich in der A-Spalte, und zwar beginnen bei A6. Es gibt 12 Tabellenblätter (Januar bis Dezember) Die Suche soll dabei in dem Arbeitsblatt des aktuellen Monats beginnen und es sollen dabei der aktuelle Monat und die 2 vorhergehenden Monate durchsucht werden. Also im August in den A-Spalten (beginnend A6) der Tabellenblätter August - Juli - Juni nach einen Wert gesucht werden, den ich vorher in einer Inputbox eingegeben habe. Wird der Wert gefunden, so soll in einer MsgBox ausgegeben werden, in welchem Tabellenblatt dieser gefunden wurde. Ich habe schon unten angegeben Code gebastelt, jedoch sucht dieser nur in der aktuell geöffneten Tabelle. Wäre schön, wenn mir wer helfen kann. Vielen Dank!!!!! Sub suchen() Dim suche As String Dim z As String suche = InputBox("wonach wollen Sie suchen?") 'Wert vorhanden z = "bereits vorhanden" 'hier ändern falls eine andere Spalte durchsucht werden soll [A6].Activate 'wenn keine Eingabe in InpuBox erfolgte wird abgebrochen If suche = "" Then Exit Sub 'bis zur ersten leeren Zelle suchen Do Until ActiveCell = "" 'eine Zeile nach unten gehen ActiveCell.Offset(1, 0).Activate 'wenn die Zelle den gesuchten Wert enthält: If ActiveCell = suche Then MsgBox "Eintrag bereits vorhanden" 'und die Zelle gelb markieren ActiveCell.Interior.ColorIndex = 36 End If Loop MsgBox "kein Eintrag gefunden" End Sub

Hallo Thomas,
ich habe drei Makros im Angebot, das dritte als reine Demo für InputBox zum -selbst gestalten-
Das erste Makro gibt die Zeile mit an wo der Suchwert gefunden wurde, das zweite nur wie oft er vorkommt.
Die Tabelle wird dabei nicht veranedert, ich kann auch ohne Select zwei Monate rückwaerts schauen!
Wird der "Januar" erreicht endet das Programm automatisch. Falls nicht gewünscht diese Zeile löschen.
Unklar ist mir noch über welche Aktion die InputBox aufgerufen werden soll?
Hast du dafür einen Button, oder eine Zelle wo du einen bestimmten Text eingibst?
Test bitte mal ob es so laeuft wie es dir gefaellt. Den Start können wir noch klaeren.
mfg Piet


Sub Makro1_mitZeile()
Dim suche As String, Sht As String
Dim Zahl As Integer, j As Integer
Dim Zeile, n As Integer, z As Long
suche = InputBox("wonach wollen Sie suchen?")
'wenn keine Eingabe in InpuBox erfolgte wird abgebrochen
If suche = "" Then Exit Sub
Zahl = ActiveSheet.Index   'Blatt Index ermitteln
'Schleife für 3 Blätter über Rückwärts Funktion (Step-1)
For j = Zahl To Zahl - 2 Step -1
With Worksheets(j).Range("A6")
'Tabellen Name zum Anzeigen
Sht = Worksheets(j).Name
z = 0: n = 0   'Zähler löschen
Zeile = Empty  'Zeile löschen
'bis zur ersten leeren Zelle suchen
Do Until .Offset(z, 0) = ""
'wenn die Zelle den gesuchten Wert enthält:
If .Offset(z, 0) = suche Then
'gefundene Zeile ermitteln
Zeile = Zeile & .Offset(z, 0).Row & "/ "
'gefundene Zelle gelb markieren
.Offset(z, 0).Interior.ColorIndex = 36
n = n + 1
End If
z = z + 1
Loop
'bei Zeile "/" am Ende wieder abschneiden
If Right(Zeile, 2) = "/ " Then Zeile = Left(Zeile, Len(Zeile) - 2)
If n > 0 Then MsgBox Sht & " - " & n & " Einträge gefunden in Zeile:" & Chr(10) & Zeile
'Abbrechen wenn Monat Januar erreicht ist!!
If Sht = "Januar" Then Exit Sub
End With
Next j
End Sub
Sub Makro2_normal()
Dim suche As String, Sht As String
Dim Zahl As Integer, j As Integer
Dim n As Integer, z As Long
suche = InputBox("wonach wollen Sie suchen?")
'wenn keine Eingabe in InpuBox erfolgte wird abgebrochen
If suche = "" Then Exit Sub
Zahl = ActiveSheet.Index   'Blatt Index ermitteln
'Schleife für 3 Blätter über Rückwärts Funktion (Step-1)
For j = Zahl To Zahl - 2 Step -1
With Worksheets(j).Range("A6")
'Tabellen Name zum Anzeigen
Sht = Worksheets(j).Name
z = 0: n = 0   'Zähler löschen
'bis zur ersten leeren Zelle suchen
Do Until .Offset(z, 0) = ""
'wenn die Zelle den gesuchten Wert enthält:
If .Offset(z, 0) = suche Then
'gefundene Zelle gelb markieren
.Offset(z, 0).Interior.ColorIndex = 36
n = n + 1
End If
z = z + 1
Loop
If n > 0 Then MsgBox Sht & "  -  " & n & " Einträge gefunden"
'Abbrechen wenn Monat Januar erreicht ist!!
If Sht = "Januar" Then Exit Sub
End With
Next j
End Sub
Sub Makro3_Input_Demo()
Dim suche As String
'InputBox mit Suchwort und Überschrift Vorganbe:
suche = InputBox("wonach wollen Sie suchen?", , "Test A6  (Suchvorgabe)")
suche = InputBox("wonach wollen Sie suchen?", "Meine Überschrift: ...", "Test A6")
suche = InputBox("wonach wollen Sie suchen?" & Chr(10) & "geht auch zweizeilig !!", , "Hallo")
End Sub

Hallo Piet!
Ich hab es getestet. Es passt noch nicht ganz.
Denn ich muss immer noch nach der 1. MsgBox Meldung auf OK klicken, erst dann wird die nächste Mappe durchsucht.
Es soll aber so sein, dass beim 1. OK-klick gleich alle Tabellen(aktuell und 2 zuvor) durchsucht werden.
Dann soll die Meldung kommen, z. B., Wert gefunden in Monat x Zeile y. Werden 2 Werte gefunden, dann
Wert gefunden in Monat x Zeile y
Wert gefunden in Monat x Zeile y
Bei sowas ähnlichem hat man mir hier auch schon mal geholfen, nur komplexer, da hier nach Einträgen in Arbeitsmappen gesucht wurden, die sich in einen anderen Laufwerk befanden.
Vielleicht hilft dir der Quellcode weiter, denn mir gelingt es einfach nicht es so nur auf die Tabellenblätter abzuändern, obwohl es einfacher ist. Ich brauche keinen Pfad und kein Datum.

Sub sbMsgBox()
Dim lstrStart As String, lstrEnd As String, ldtDays As Date, lstrMsgBox As String, _
lstrPath As String
Dim larCur() As Variant, larFile() As Variant, liIdxCur As Integer, liIdxFile As Integer
Dim strFileSuch As String, strFile As String
Dim wkbTrans As Workbook
With ufDate
lstrStart = .cmbStD.Text & "." & .cmbStM.Text & "." & .cmbStY.Text
lstrEnd = .cmbEdD.Text & "." & .cmbEdM.Text & "." & .cmbEdY.Text
End With
If CDate(lstrStart) > CDate(lstrEnd) Then
MsgBox "Das Start-Datum ist größer als das End-Datum." & vbCrLf _
& "Bitte korrigieren", _
vbExclamation, "Hinweis"
Exit Sub
End If
Application.ScreenUpdating = False
lstrPath = "D:\Buchungen\" 'anpassen, wenn erforderlich!
lstrPath = IIf(Right(lstrPath, 1) = "\", lstrPath, lstrPath & "\")
For ldtDays = CDate(lstrStart) To CDate(lstrEnd)
'Datei-Suchstring für Dateisuche mit Funktion Dir
strFileSuch = "Transfer - " & Format(ldtDays, "DD.MM.YY") & " ?.?.xlsx"
'Datei(en) suchen
strFile = Dir(lstrPath & strFileSuch, vbNormal)
Do Until strFile = ""
larCur = Range("C2:G" & Cells(Rows.Count, 3).End(xlUp).Row)
'Datei schreibgeschützt öffnen
Set wkbTrans = Workbooks.Open(lstrPath & strFile, ReadOnly:=True)
With wkbTrans.Worksheets(1)
larFile = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp).Offset(0, 4)).  _
_
Value2
End With
wkbTrans.Close False
For liIdxCur = 1 To UBound(larCur, 1)
For liIdxFile = 1 To UBound(larFile, 1)
If larCur(liIdxCur, 1) = larFile(liIdxFile, 1) And _
larCur(liIdxCur, 5) = larFile(liIdxFile, 5) Then
lstrMsgBox = lstrMsgBox & "Datei ''" _
& ThisWorkbook.Name & "'', Zeile " & liIdxCur + 1 _
& " gefunden in Datei ''" & strFile & "'', Zeile " _
& liIdxFile + 1 _
& " Betrag: " & larFile(liIdxFile, 5) & " " & vbCrLf
End If
Next
Next
'nächste Datei suchen
strFile = Dir
Loop
Next
Application.ScreenUpdating = True
If lstrMsgBox = "" Then
MsgBox "Es existieren keine Dateien mit Namen aus dem angegebenen Datumsbereich.", _
vbExclamation, "Hinweis"
Exit Sub
Else
uf_Meldung.lbl_Text = lstrMsgBox
uf_Meldung.Show
End If
End Sub

Forumthread: Wert in mehreren Tabellen suchen

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Werte in mehreren Tabellenblättern suchen und ausgeben

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)