WVERWEIS mit Bezug auf mehrere dynamische, externe Dateien (VBA)

paul.david, Mittwoch, 08.05.2019, 11:18 (vor 197 Tagen)

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\"      'Pfad ggf. anpassn
    On Error GoTo Errhandler
 
    Set wbDestiny = ThisWorkbook ' Workbooks("Paul.xlsm") 'HIER NAME DER ZIELDATEI ENTSPRECHEND  _
 _
 _
ÄNDERN
    
    'HINWEIS QUELLDATEIEN R DURCHSCHLEIFEN
    For Each r In wbDestiny.Sheets("A").Range("D3:D21").Cells 'Blattname ggf anpassen
        If r.Text = "Projekt" Then
            r.Offset(0, 4).Value = "" '??? ggf. Zeile weglasen
        Else
            sDatei = sPfadQuelle & "Info_" & r.Text & ".xlsx" 'HIER Syntaxt für Dateiname ggf.   _
 _
_
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

gesamter Thread:

 RSS-Feed dieser Diskussion

powered by my little forum