Excel VBA: Inhalt einer Zelle suchen und in Relation zu dieser Zelle Werte auslesen

Mitglied: Temudschin79

Temudschin79 (Level 1) - Jetzt verbinden

14.04.2021 um 14:52 Uhr, 463 Aufrufe, 8 Kommentare

Guten Tag Zusammen

Erstmal vielen Dank an alle für die Hilfe zuvor. Ich konnte innerhalb von 2 Tagen einiges über VBA Lernen.

Nun zu meinem Problem: Ich möchte mehrere Exceldateien nach bestimmten Werten durchsuchen und die Werte aufnehmen.
Momentan funktioniert das auch schon mit festen Zellen, die ich auslese. Ich würde aber lieber den Inhalt (Überschrift) einer Zelle suchen und in Relation (Eine Zeile tiefer bzw. eine Spalte weiter nach rechts) die Inhalte auslesen.

Z.B. In Zelle C29 Steht das Wort "Finding" dies Steht immer in der Spalte C, kann aber in anderen Dokumenten in einer anderen Zeile stehen. (Ich suche ja in mehreren Exceldokumenten)
Von dort aus möchte ich eine Spalte nach rechts und eine Zeile nach unten die nachstehenden Werte auslesen. Z.B. D30-D35. Dabei ist mir besonders wichtig, das sich die durchsuchten Exceltabellen auf keinen Fall verändern oder Beeinträchtigt werden.

Vielen Dank im Voraus für eure Hilfen.

Nachgetragen möchte ich den bisher erstellten Code für alle veröffentlichen. Ich denke durch die Kommentare können auch andere etwas aus dem Code lernen. Falls Fehler im Code sind, freue ich mich auch über Rückmeldungen; immerhin bin ich absoluter Anfänger in VBA.

Schöne Grüße

Option Explicit
Option Compare Text
'
' Verzeichnisse inklusive Unterverzeichnisse nach "*Beispiel*.xlsx" Dateien suchen, Auflisten und bestimmte Zellen auslesen
'

Dim sRootPath As String
Private lRowCounter As Long
Private oSheet As Object

'Start der Routine: Call DateienMitUnterordnernAuslesen
Public Sub DateienMitUnterordnernAuslesen()
Set oSheet = Sheets.Add 'Neues Sheet erstellen
oSheet.Activate 'Neues Sheet aktivieren
oSheet.Cells(1, 1).Select 'Zelle Oben Links wählen
Call CreateHeadLinesAndFormat 'Erstelle und formatiere die Headlines
lRowCounter = 2 'Beginne in Zeile zwei mit der Aufnahme von Daten
sRootPath = InputBox("Pfad eingeben", "sRootPath") 'Inputbox zur Pfadeingabe
Call ReadSubFolder(sRootPath) 'Durchsuche die (Unter-)Verzeichnisse nach Dateien und entnehme die Werte
Set oSheet = Nothing 'oSheet leeren/schließen
End Sub

'Formatiere die Headlines
Private Sub CreateHeadLinesAndFormat()
Dim i As Long

oSheet.Cells(1, 1) = "Pfad" 'Setze die Spalte Pfad
oSheet.Cells(1, 2) = "Dateiname" 'Setze die Spalte Dateiname
oSheet.Cells(1, 3) = "FS" 'Setze die Spalte FS
oSheet.Cells(1, 4) = "F" 'Setze die Spalte F
oSheet.Cells(1, 5) = "C" 'Setze die Spalte C
oSheet.Cells(1, 6) = "E" 'Setze die Spalte E
oSheet.Cells(1, 7) = "SQA" 'Setze die Spalte SQA
oSheet.Cells(1, 8) = "I" 'Setze die Spalte I
oSheet.Columns(1).ColumnWidth = 40 'Setze die Spaltenbreite auf 40
oSheet.Columns(2).ColumnWidth = 40 'Setze die Spaltenbreite auf 40

For i = 1 To 2 'Formatiere die ersten beiden Headlines ("Pfad" und "Dateiname")
With oSheet
.Cells(1, i).Interior.ColorIndex = 11 'Formatiere die Zellenfarbe
.Cells(1, i).Font.Color = vbWhite 'Formatiere die Textfarbe
.Cells(1, i).Font.Bold = True 'Formatiere die Schriftart
End With
Next i
End Sub

'Suche in den (Unter-)Verzeichnissen nach Dateien im Format "*Beispiel*.xlsx"
Private Sub ReadSubFolder(ByVal sFolderPath As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
Dim sPath As String
Dim sContent As String
Dim sTab As String
Dim sFile As String
Dim sCell As String

Set oFSO = CreateObject("Scripting.FileSystemObject") 'erstelle das FileSystemObject
Set oFolder = oFSO.getfolder(sFolderPath) 'Momentaner Pfad/Path

With oSheet 'Nur auf oSheet arbeiten!

For Each oSubFolder In oFolder.subfolders 'Fuer jedes Verzeichnis

'Alle Dateien auflisten
For Each oFile In oSubFolder.Files 'Solange Dateien vorhanden sind
If oFile Like "*Review*.xlsx" Then 'und die Dateien dem Format entsprechen
.Cells(lRowCounter, 1) = oSubFolder.Path 'werden Pfad und
.Cells(lRowCounter, 2) = oFile.Name 'Dateiname ins ExcelTab geschrieben
sPath = oSubFolder.Path 'Danach wird der Pfad,
sFile = oFile.Name 'Dateiname
sTab = "Cover" 'und der Reitername
sCell = "D30" 'der Zelle gewählt

' Eintragen in Zelle
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 3) = sContent 'und in ExcelDokument eingetragen

'
Eintragen in Zelle
sCell = "D31" 'Zelle wählen
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 4) = sContent 'und in ExcelDokument eingetragen

' Eintragen in Zelle
sCell = "D32" 'Zelle wählen
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 5) = sContent 'und in ExcelDokument eingetragen

'
Eintragen in Zelle
sCell = "D33" 'Zelle wählen
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 6) = sContent 'und in ExcelDokument eingetragen

' Eintragen in Zelle
sCell = "D34" 'Zelle wählen
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 7) = sContent 'und in ExcelDokument eingetragen

'
Eintragen in Zelle
sCell = "D35" 'Zelle wählen
sContent = GetValue(sPath, sFile, sTab, sCell) 'Entsprechende Zelle wird ausgelesen
.Cells(lRowCounter, 8) = sContent 'und in ExcelDokument eingetragen


lRowCounter = lRowCounter + 1 'Zeile für nächsten Durchlauf setzen
End If
Next oFile 'Nächste Datei wählen

'Alle Unterverzeichnisse verarbeiten (rekursiv)
Call ReadSubFolder(oSubFolder.Path) 'nächstes Verzeichnis durchgehen

Next oSubFolder 'Nächstes Verzeichnis

End With 'Ende der Bearbeitung von oSheet

Set oFSO = Nothing 'Alles zurücksetzen bzw. schließen
Set oFile = Nothing 'Alles zurücksetzen bzw. schließen
Set oFolder = Nothing 'Alles zurücksetzen bzw. schließen
Set oSubFolder = Nothing 'Alles zurücksetzen bzw. schließen
End Sub

'Daten aus geschlossener Arbeitsmappe auslesen
Private Function GetValue(sPath, sFile, sTab, sCell)
Dim arg As String

If Right(sPath, 1) <> "\" Then sPath = sPath & "\" 'Sicherstellen, dass der Pfad vorhanden und gesetzt ist
If Dir(sPath & sFile) = "" Then 'Sicherstellen, dass eine datei vorhanden ist
GetValue = "File Not Found" 'Wenn nicht, dann "File Not Fonud" Ausgeben
Exit Function
End If

'Das Argument erstellen
arg = "'" & sPath & "[" & sFile & "]" & sTab & "'!" & Range(sCell).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg) 'Auslesen über Excel4Macro

End Function
Mitglied: spinnifex
LÖSUNG 14.04.2021 um 16:22 Uhr
Hallo End Function,

ich bin ehrlich, den ganzen Code zu analysieren habe ich mir erspart, aber als kleine Hilfe für Deine Tabellen Folgendes

Schöne Grüße
Spinnifex
Bitte warten ..
Mitglied: warranty
LÖSUNG 14.04.2021, aktualisiert um 16:26 Uhr
Suchen und Offset ausgeben, kein Thema ...
https://docs.microsoft.com/de-de/office/vba/api/excel.range.find
https://docs.microsoft.com/de-de/office/vba/api/excel.range.offset

G. w.
Bitte warten ..
Mitglied: spinnifex
LÖSUNG 14.04.2021 um 16:36 Uhr
Lösung zwei ist definitiv besser! ;-) face-wink
Bitte warten ..
Mitglied: Temudschin79
15.04.2021 um 09:48 Uhr
Vielen Dank für die Hilfe.

Ich habe es ausprobiert. Leider sucht er nur in dem Sheet, in dem ich das VBA ausführe. Ich möchte natürlich in den Files suchen, die ich gefunden habe. Also nicht in oSheet sondern in den Files, die ich über
"GetValue = ExecuteExcel4Macro(arg) 'Auslesen über Excel4Macro"
auslese.

Kannst du mir auch da weiterhelfen?

Grüße
Temudschin79
Bitte warten ..
Mitglied: warranty
LÖSUNG 15.04.2021, aktualisiert um 10:35 Uhr
Kannst du nen ForEach Loop mit deinen Dateien drum basteln und dann den hier festen Pfad durch die Laufvariable deines Loops und den Tabellennamen oder Nummer austauschen ....
Fertsch.
Bitte warten ..
Mitglied: warranty
LÖSUNG 15.04.2021, aktualisiert um 10:55 Uhr
Alter hast du nervöse Zuckungen? Beiträge im Minuten Takt erstellen und dann doch gleich wieder löschen?? Was soll das?

Ich bin jetzt raus.

Thread-Notification = OFF
Bitte warten ..
Mitglied: Temudschin79
15.04.2021 um 11:22 Uhr
Super! Hat funktioniert!

Vielen Dank "warranty"

Und auch vielen Dank an "spinnifex"
Bitte warten ..
Mitglied: Temudschin79
15.04.2021 um 11:57 Uhr
Sorry, dass ich die Frage direkt wieder gelöscht habe...
Du hattest in deiner Lösung vorher
With GetObject("D:\datei.xlsx").Sheets(1)
stehen. Meine Frage bezog sich dann darauf, ob ich einfach
With GetObject("D:\datei.xlsx").Sheets("Cover")
schreiben kann.
Als ich meine Frage online hatte, hast du wohl schon deine Lösung zu
With GetObject("D:\datei.xlsx").Sheets("TabelleXYZ")
geändert. Was meine Frage natürlich sofort beantwortet hat. Daher hatte ich sie direkt wieder zurückgezogen.
Bitte warten ..
Heiß diskutierte Inhalte
Datenschutz
FAX ist nicht mehr Datenschutzkonform
brammerVor 1 TagInformationDatenschutz52 Kommentare

Hallo, jetzt sollte es jeder begreifen FAX ist nicht mehr Datenschutzkonform brammer

Humor (lol)
Na, kann euer Toaster auch schon WLAN?
ITlerin95Vor 1 TagAllgemeinHumor (lol)16 Kommentare

Also ich frag mich ja selbst echt oft, ob wirkliche alle technischen Neuerungen auch wirklich notwendig sind. Hintergrund ist, ich brauch einen neuen Toaster. ...

Windows Update
Keine Updates zum Mai-Patchday über WSUS?
gelöst CoreknabeVor 1 TagFrageWindows Update12 Kommentare

Moin, wir laden über unseren WSUS die Windows Updates herunter (Server 2012R2). Jetzt stelle ich gerade verwundert fest, dass es Stand jetzt (19:45 Uhr) ...

Netzwerkgrundlagen
Statische Route auf UTM
gelöst Ex0r2k16Vor 14 StundenFrageNetzwerkgrundlagen31 Kommentare

Moin! Ich habe an meiner Sophos UTM an einem physischen Interface einen Switch angeschlossen. Dieser läuft im Netz 10.1.1.0/24. Ich kann von meinem aktuellen ...

Exchange Server
Sicherheitsupdates für Exchange Server 11. Mai 2021
kgbornVor 1 TagInformationExchange Server4 Kommentare

Sicherheitsupdates für Exchange Server 11. Mai 2021 Technet-Beitrag Meine Zusammenstellung: Sicherheitsupdates (KB5003435) für Microsoft Exchange Server (11. Mai 2021)

Exchange Server
Office 365 ohne lokalen Exchange
RicoPausBVor 1 TagFrageExchange Server8 Kommentare

Moin zusammen wir sind erst vor kurzem ins Office 365 eingestiegen und hatten vorher auch keinen Exchange Server im Einsatz. Ein Hybrid-Setup liegt also ...

SAN, NAS, DAS
Synology-NAS DS1813+: Lebensdauer des Gerätes?
OrmensonVor 1 TagFrageSAN, NAS, DAS10 Kommentare

Hallo Forum! In unserer Firma nutzen wir ein Synology NAS DS1813+ als zentraler Datenspeicherort. Konfiguriert ist er als RAID mit Ausfallsicherheit einer Platte. Die ...

Microsoft Office
Weiterleitung bestimmter Emails während Urlaubszeit
gelöst imebroVor 1 TagFrageMicrosoft Office11 Kommentare

Hallo, verschiedene Rechnungen werden an meine Email-Adresse gesendet. Daher habe ich vor einiger Zeit eine Outlook-Regel in meinem Outlook-Postfach erstellt, die automatisch Emails mit ...