temudschin79
Goto Top

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

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

Content-Key: 665731

Url: https://administrator.de/contentid/665731

Ausgedruckt am: 28.03.2024 um 17:03 Uhr

Mitglied: spinnifex
Lösung spinnifex 14.04.2021 um 16:22:34 Uhr
Goto Top
Hallo End Function,

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

Sub SuchenVBA()
Dim rngAdresse As Range
Dim strKeyword As String
Dim varData 'as Variant  

strKeyword = "Finding"  
Set rngAdresse = ActiveWorkbook.ActiveSheet.UsedRange.Find(strKeyword, LookIn:=xlValues, Lookat:=xlPart)

If Not rngAdresse Is Nothing Then
    varData = Cells(rngAdresse.Row + 1, rngAdresse.Column + 1).Value
    MsgBox "... steht der Wert " & varData, , "rechts unterhalb von Zelle " & rngAdresse.Address & " ..."  
End If
End Sub

Schöne Grüße
Spinnifex
Mitglied: 148121
Lösung 148121 14.04.2021 aktualisiert um 16:26:04 Uhr
Goto Top
Suchen und Offset ausgeben, kein Thema ...
dim result as Range
set result = oSheet.Range("C:C").Find("Finding",LookIn:=xlValues)  
if not result is nothing then
    msgbox result.Offset(1,1).Value
else
    msgbox "Nix gefunden"  
End if
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.
Mitglied: spinnifex
Lösung spinnifex 14.04.2021 um 16:36:23 Uhr
Goto Top
Lösung zwei ist definitiv besser! face-wink
Mitglied: Temudschin79
Temudschin79 15.04.2021 um 09:48:12 Uhr
Goto Top
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
Mitglied: 148121
Lösung 148121 15.04.2021 aktualisiert um 10:35:33 Uhr
Goto Top
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 ....
With GetObject("D:\datei.xlsx").Sheets("TabelleXYZ")  
    dim result as Range
    set result = .Range("C:C").Find("Finding",LookIn:=xlValues)  
    if not result is nothing then
        msgbox result.Offset(1,1).Value
     else
         msgbox "Nix gefunden"  
    End if
    .Parent.Close False
End with
Fertsch.
Mitglied: 148121
Lösung 148121 15.04.2021 aktualisiert um 10:55:47 Uhr
Goto Top
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
Mitglied: Temudschin79
Temudschin79 15.04.2021 um 11:22:36 Uhr
Goto Top
Super! Hat funktioniert!

Vielen Dank "warranty"

Und auch vielen Dank an "spinnifex"
Mitglied: Temudschin79
Temudschin79 15.04.2021 um 11:57:43 Uhr
Goto Top
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.