Hallo Zusammen,
ich habe eine Tabelle, in der für jeden Mitarbeiter (Spalte B3:B14) und Monat (Zeile C2:Z2) erfasst werden soll, wieviel Stunden derjenige gearbeitet hat.
Nun sollen die entsprechenden Werte aus einzelnen Dateien gezogen werden. Der Dateiname ist immer gleich: Info_“Name“ („Name“ entsprechend dem Wert in Spalte B).
Auch der Aufbau in den Dateien, aus denen die Werte ausgelesen werden sollen, ist immer gleich. In Spalte E4:E14 stehen die Monate (Jan-Dez) rechts daneben in Spalte F3:F14 die entsprechenden auszulesenden Werte.
Es gibt also zwei Herausforderungen:
1. Die Werte aus verschiedenen Dateien mit dynamischen Dateinamen auslesen
2. Die Suchkriterien in der Zieldatei sind horizontal angeordnet (Zeile C2:Z2), in den auszulesenden Dateien jedoch vertikal (E4:E14 bzw. F3:F14).
Ich habe bereits einen SVERWEIS mit Bezug auf Dateien mit dynamischen Dateinamen hinbekommen, jedoch gelingt es mir bisher nicht es entsprechend umzuschreiben :( unten seht ihr den alten Code)
Vielen Dank vorab für eure Unterstützung!
Paul
Sub LookupValues()
Dim r As Range
Dim wbLookup As Workbook, wbDestiny As Workbook
Dim searchRange As Range
Dim searchValue As Variant
Dim sPfadQuelle As String, sDatei As String
Dim varWert
Application.ScreenUpdating = False
sPfadQuelle = "C:\Users\xxx\Desktop\Test\"
On Error GoTo Errhandler
Set wbDestiny = ThisWorkbook
_
_
ÄNDERN
For Each r In wbDestiny.Sheets("A").Range("D3:D21").Cells
If r.Text = "Projekt" Then
r.Offset(0, 4).Value = ""
Else
sDatei = sPfadQuelle & "Info_" & r.Text & ".xlsx"
_
_
ANPASSEN
If Dir(sDatei) = "" Then
MsgBox "Datei """ & sDatei & """ niht gefunden"
Else
searchValue = r.Offset(0, -3).Value
Set wbLookup = Workbooks.Open(sDatei, ReadOnly:=True)
Set searchRange = wbLookup.Sheets(1).Range("A4:C27")
varWert = Application.VLookup(searchValue, searchRange, 3, False)
If IsError(varWert) Then
r.Offset(0, 4).Value = "#NV!"
Else
r.Offset(0, 4).Value = varWert
End If
wbLookup.Close savechanges:=False
End If
End If
Next r
GoTo Beenden
Errhandler:
MsgBox Err.Description, vbCritical
Beenden:
Application.ScreenUpdating = True
End Sub