Wie suche ich nach einem bestimmten Zelleninhalt ? - VBA

Question

Hallo liebe VBA-Profis,

ich möchte gerne den Inhalt (z.B. nach einem bestimmten Namen) einer bestimmten
Zelle in einer CSV Datei suchen und den Inhalt der rechten Nachbarzelle der
gesuchten Zelle oder die 2. rechte Nachbarzelle auslesen und in der Makro-datei
auflisten.

Könnt ihr mir weiterhelfen?

Besten Dank im Vorwege!

Viele Grüße
Flo_DF

Answer 1

Hallo Flo,

steht der gesuchte Inhalt exklusiv in der Zelle (Zellinhalt = Suchbegriff) oder ist er Bestandteil eines Textes in der Zelle?
Und soll der Suchbegriff abgefragt werden, oder ist es immer ein feststehender Begriff?

Gruß

M.O.

Answer 2

Hallo M.O.

Ja, genau, der Suchbegriff ist auch der Zelleninhalt wie z.B. "Name:"
und er soll mir dann die Nachbarzelle bzw. die rechte 2. Zelle von
"Name:" ausgeben.

Der Suchbegriff ist gleich, jedoch variiert die Position der Zelle.

Hast du eine Idee für mich?

Besten Gruß
Flo

Answer 3

Hallo Flo,

hier mal ein Beispiel, wie man das lösen kann. Das Makro gehört in ein allgemeines Modul deiner Arbeitsmappe:

Sub suchen()

Dim Datei As Variant
Dim strSuchb As String
Dim Quelle As String
Dim rngZelle As Range
Dim lngZeile As Long
Dim vInhalt As Variant
Dim i As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Suchbegriff festlegen
strSuchb = "Name:"

'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename("CSV-Dateien (*.csv),*.csv,Alle Dateien (*.*),*.*")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
Exit Sub
End If

'ausgewählte Datei öffnen
Workbooks.Open (Datei)

'Quelldatei festlegen
Quelle = ActiveWorkbook.Name 'geöffnete Datei

'geöffnete Datei durchsuchen
For Each rngZelle In Workbooks(Quelle).Worksheets(1).UsedRange
'Inhalt wird eingelesen und aufgeteilt; Unterscheidungsmerkmal hier Semikolon, ggf. anpassen
vInhalt = Split(rngZelle.Value, ";")
'Falls Suchbegriff gefunden wird..
For i = 0 To UBound(vInhalt)
If vInhalt(i) = strSuchb Then
'letzte Zeile in aktueller Datei im Arbeitsblatt Tabelle1, Spalte A ermitteln
lngZeile = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
'dann kopieren
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 1) = Quelle 'Name der geöffneten Datei in Spalte A schreiben
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 2) = vInhalt(i + 1) 'Zelle rechts neben gefundenen Begriff in Spalte B
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 3) = vInhalt(i + 2) '2. Zelle rechts neben gefundenen Begriff in Spalte c
'Schleife verlassen
Exit For
End If
Next i
Next rngZelle

'geöffnete Datei wieder schließen ohne zu speichern
Workbooks(Quelle).Close False

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 4

Hallo M.O.,

genau das Script habe ich gesucht. Vielen Dank! :)

Ist es möglich alle Zellen unterhalb von der Suchzelle Name:
auszulesen? Wobei die Endzelle bei einem gewissen Zellewert wie
Straße: enden soll.

Viele Grüße
Flo

Answer 5

Hallo Flo,

verstehe ich das richtig. Wenn z.B. Name: in der 2 Position (Zelle) gefunden wird, dann soll von allen folgenden Sätzen auch der Inhalt der 2. Position ausgegeben werden, bis dieser Inhalt Straße: ist.

Sollen diese Sätze dann einfach ab Spalte D eingefügt werden?

Gruß

M.O.

Answer 6

Hallo M.O. :)

Ja, genau die Zelleninhalte der Spalte in der der Suchbegriff Name:
auftaucht. Beispiel G10 = Name: G20 = Straße: sodass G11:G19
auszulesen sind.

VG
Flo

Answer 7

Hallo Flo,

probier mal das folgende Makro:

Sub suchen()

Dim Datei As Variant
Dim strSuchb As String
Dim Quelle As String
Dim rngZelle As Range
Dim lngZeile As Long
Dim lngSpalte As Long
Dim vInhalt As Variant
Dim i As Long
Dim lngPos As Long
Dim bAuslesen As Boolean
Dim lngz1 As Long
Dim lngz2 As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Suchbegriff festlegen
strSuchb = "Name:"

'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename("CSV-Dateien (*.csv),*.csv,Alle Dateien (*.*),*.*")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
Exit Sub
End If

'ausgewählte Datei öffnen
Workbooks.Open (Datei)

'Quelldatei festlegen
Quelle = ActiveWorkbook.Name 'geöffnete Datei

'geöffnete Datei durchsuchen
For Each rngZelle In Workbooks(Quelle).Worksheets(1).UsedRange
'Inhalt wird eingelesen und aufgeteilt; Unterscheidungsmerkmal hier Semikolon, ggf. anpassen
vInhalt = Split(rngZelle.Value, ";")
'Zähler wird hochgesetzt
lngz1 = lngz1 + 1
'Falls Suchbegriff gefunden wird..
For i = 0 To UBound(vInhalt)
If vInhalt(i) = strSuchb Then
'letzte Zeile in aktueller Datei im Arbeitsblatt Tabelle1, Spalte A ermitteln
lngZeile = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
'dann kopieren
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 1) = Quelle 'Name der geöffneten Datei in Spalte A schreiben
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 2) = vInhalt(i + 1) 'Zelle rechts neben gefundenen Begriff in Spalte B
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 3) = vInhalt(i + 2) '2. Zelle rechts neben gefundenen Begriff in Spalte c
'gefundene Position wird in Variable geschrieben für das Auslesen weiterer Sätze
lngPos = i
'Schalter für Auslesen weiterer Datensätze auf Wahr setzen
bAuslesen = True
'Zähler wird in Variable geschrieben,
lngz2 = lngz1
'Schleife verlassen
Exit For
End If
Next i

'Prüfen ob der Schalter Auslesen = Wahr ist und nur Datensätze nach dem gefundenen Datensatz überprüft werden
If bAuslesen = True And lngz1 > lngz2 Then
'Prüfen, ob der Begriff Straße: im Feld steht
If vInhalt(lngPos) <> "Straße:" Then
'falls nicht, letzte Spalte in der Zeile ermitteln und um 1 erhöhen und den Inhalt in Spalte schreiben
lngSpalte = ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, Columns.Count).End(xlToLeft).Column + 1
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, lngSpalte) = vInhalt(lngPos)
Else
'falls Begriff gefunden wird, Schalter wieder auf Falsch setzen
bAuslesen = False
End If
End If

Next rngZelle

'geöffnete Datei wieder schließen ohne zu speichern
Workbooks(Quelle).Close False

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß
M.O.

Answer 8

Hallo M.O.

ich habe eben einen Versuch mit deinem Script gemacht, jedoch bekomme ich einen
"Laufzeitfehler '9'. Index außerhalb des gültigen Bereichs."

Beim Debuggen ist die erste markierte Zeile:
If vInhalt(lngPos) <> "Zwischensumme:" Then

Desweiteren erstellt das Makro eine neue Exceldatei mit dem gesamten Inhalt der zu durchsuchenden Datei.
Dabei werden alle Leerzeichen durch den Split mit ";" dargestellt.

Ich möchte einfach nur die den Inhalt zwischen den beiden Suchwörtern in Spalte
ThisWorkbook.Worksheets("Tabelle1").Cells(lngZeile, 4) ausgeben.

Vielen Dank im Voraus!

Gruß
Flo

Answer 9

Hallo Flo,

bei meiner Testdatei funktioniert das Makro ohne Probleme.

Desweiteren erstellt das Makro eine neue Exceldatei mit dem gesamten Inhalt der zu durchsuchenden Datei.
Dabei werden alle Leerzeichen durch den Split mit ";" dargestellt.

Das kann ich überhaupt nicht nachvollziehen. Was meinst du damit?

Kannst du ggf. mal eine CSV-Datei mit ein paar Dummydaten auf einem Hoster deiner Wahl, z.B. hier, hochladen und den Link hier posten? Der Aufbau der Datei sollte aber der richtigen CSV-Datei entsprechen.

Gruß

M.O.

Answer 10

Hallo M.O.,

ich habe ein Script aus diesem Forum gefunden, dass auch das gesamte Verzeichnis einliest.
Ich würde gerne das übernehmen wollen.

Es soll nun die gesamte Spalte A zwischen den Werten "Menge" und "High", die sich in Spalte A befinden, im Zielsheet
"Auswertung" in die erste freie Zelle in Spalte A ausgeben.

Danach soll wieder den Bereich ab dem Inhalt "Menge" und "High", die sich in Spalte A befinden, durchgehen, jedoch soll er
dann in diesem Bereich die Spalte B( nicht wieder A) im Zielsheet "Auswertung" in die erste freie Zelle in Spalte B ausgeben.

Dabei möchte ich, dass alle ausgelesenen Werte eines Sheets bei jeder neu ausgelesenen Zelle mit einem Zeilenumbruch in
das Zielworksheet "Auswertung" in eine einzige Zelle kopiert wird.

Es kann sein, dass diese Abgrenzung von "Menge" und "High" mehrmals vorkommt. Daher Soll das Makro solange durchlaufen
bis zur letzten beschriebenen Zeile im Sheet.

Ich hoffe, du konntest mir folgen.

Vielen Dank schon einmal:)



Sub Auswertung_start()
'Objektverweise zuweisen
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.getfolder("C:\folder")
Set wksAuswertsheet = ThisWorkbook.Sheets("Auswertung")

Call Dateien_auswerten

'Zuweisung wieder aufheben
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing

'Text aus Statusbar löschen
Application.StatusBar = ""
End Sub
'###########################################################################################

Sub Dateien_auswerten()

Application.ScreenUpdating = False

For Each objDatei In objDateien.Files
If Right(objDatei.Name, 4) = ".csv" Then

'erste freie Zelle in der Zieldatei in Spalte A ermitteln
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'Meldung in Statusbar anzeigen
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents

'Gefundene Datei unsichtbar öffnen
GetObject (objDatei)


'Alle Werte aus Spalte A zwischen dem Bereich "Menge" bis "High" aus Spalte A auslesen
wksAuswertsheet.Cells(lngFirstFreeRow, 1) = _
Workbooks(objDatei.Name).Sheets(1).Range(??:??)


'Alle Werte aus Spalte B zwischen dem Bereich "Menge" bis "High" aus Spalte A auslesen
wksAuswertsheet.Cells(lngFirstFreeRow, 2) = _
Workbooks(objDatei.Name).Sheets(1).Range(??:??)


wksAuswertsheet.Cells(lngFirstFreeRow, 3) = Workbooks(objDatei.Name).Sheets(1).Name

'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close savechanges:=False

End If
Next

'Nächstes Verzeichnis abfragen
For Each objWeitereDateien In objDateien.subfolders
Set objDateien = objWeitereDateien
Call Dateien_auswerten
Next

End Sub



Viele Grüße und Danke noch einmal!!
Flo