Makro zur Tabellenverknüpfung

Guten Morgen Zusammen,
ich bräuchte eure Hilfe zu einem Makro. Ich hoffe ich erkläre mein Problem verständlich:
Und zwar habe ich eine Datei die sich Jahresübersicht nennt. In dieser Tabelle wird jeder Tag in einer Spalte abgebildet, d.h. in Zelle A2 steht 01.01.2019, in Zelle B2 steht 02.02.2019 usw.
Unterhalb dieser Datumsangaben werden täglich aktuelle Werte von Hand hinterlegt. Diese Tageswerte kommen aus einer CSV Datei die jeden Tag automatisiert mit dem aktuellen Datum (gleich der Spaltenüberschrift z. B. 01.01.2019) in einem Ordner abgespeichert wird.
Nun meine Frage: Kann mithilfe eines Makros beim Öffnen der Datei geprüft werden, ob zu dem Datum der Spaltenüberschrift bereits eine gleichnamige Datei in dem Ordner besteht und wenn ja, er automatisiert immer bestimmte Zellen aus der Tageswertedatei in die Jahresübersicht übernimmt? Beispielsweise muss, wenn eine passende Tageswert- Datei vorhanden ist, immer die Zelle B2 der CSV Datei in die Zeile 13 der Jahresübersicht des übereinstimmenden Datumsspalte übertragen werden.
Vielen Dank schon mal für die Hilfe!
Gruß Fabian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Übertragen() Dim Pfad As String, Datum As String, Ext As String, Z As Long, Zelle As String Dim i As Integer, WB1, TB1, WB2, LC As Integer 'Vorgaben##### Set WB1 = ActiveWorkbook Set TB1 = WB1.Sheets("Tabelle1") Pfad = "X:\Temp\Test\" Ext = ".csv" '!!!! bei CSV gibt es nur ein Blatt, das genau wie die Datei heißt 'Ende Vorgaben## Pfad = Pfad & IIf(Right(Pfad, 1) = "\", "", "\") 'prüfen, ob am Ende ein \ steht 'Prüfen, ob Pfad existiert## If Dir(Pfad, vbDirectory) = "" Then MsgBox "Pfad existiert nicht" Exit Sub End If LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile 1 'alle Einträge in Zeile 1 abarbeiten For i = 1 To LC 'prüfen, ob bereits Daten eingetragen sind If TB1.Cells(13, i) = "" Then 'prüfen, ob Datei existiert Datum = TB1.Cells(1, i) If Dir(Pfad & Datum & Ext) <> "" Then 'Datei ist da '#### Z = 13 'Zielzeile Zelle = "B2" 'Wert B2 auslesen '#### With TB1.Cells(Z, i) .Formula = "='[" & Datum & Ext & "]" & Datum & "'!" & Zelle & "" 'per Formel, ohne Datei zu öffnen .Value = .Value 'Formel in Wert ändern End With 'mögliche Weitere Werte nach gleichen Muster '#### Z = 14 Zelle = "D4" '#### With TB1.Cells(Z, i) .Formula = "='[" & Datum & Ext & "]" & Datum & "'!" & Zelle & "" .Value = .Value End With End If End If Next End Sub

und eleganterer Angabe der zu übertragenden Zellen...
Modul1

Option Explicit 
 
Sub Übertragen2() 
    Dim Pfad As String, Datei As String, Ext As String 
    Dim i As Integer, WB1, TB1, WB2, TB2, LC As Integer 
    Dim ArrZielz(), ArrZelle(), S 
     
    'Vorgaben##### 
    Set WB1 = ActiveWorkbook 
    Set TB1 = WB1.Sheets("Tabelle1") 
    Pfad = "X:\Temp\Test\" 
    Ext = ".csv" 
    '!!!! bei CSV gibt es nur ein Blatt, das genau wie die Datei heißt 
     
    ArrZielz = Array("13", "14", "17") 'Zielzeilen 
    ArrZelle = Array("B2", "D4", "X1") 'aus diesen Zelle lesen 
     
    'Ende Vorgaben## 
     
     
    Application.ScreenUpdating = False 
     
    'Prüfen Formalfehler 
    If Ubound(ArrZielz) <> Ubound(ArrZelle) Then 
        MsgBox "Arrayfehler" 
        Exit Sub 
    End If 
    Pfad = Pfad & IIf(Right(Pfad, 1) = "\", "", "\")  'prüfen, ob am Ende ein \ steht 
     
    'Prüfen, ob Pfad existiert## 
    If Dir(Pfad, vbDirectory) = "" Then 
        MsgBox "Pfad existiert nicht" 
        Exit Sub 
    End If 
     
    LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile 1 
     
    'alle Einträge in Zeile 1 abarbeiten 
    For i = 1 To LC 
         
        'prüfen, ob bereits Daten in erster Zielzelle eingetragen sind 
        If TB1.Cells(ArrZielz(Lbound(ArrZielz)), i) = "" Then 
             
            Datei = TB1.Cells(1, i) 
             
            'prüfen, ob Datei existiert 
            If Dir(Pfad & Datei & Ext) <> "" Then 
                 
                'Datei ist da >>> öffnen 
                Set WB2 = Workbooks.Open(Filename:=Pfad & Datei & Ext, Local:=True) 
                Set TB2 = WB2.Sheets(1) 
                 
                'Array abarbeiten 
                For S = Lbound(ArrZielz) To Ubound(ArrZielz) 
                     
                    'Werte übertragen 
                    TB1.Cells(ArrZielz(S), i) = TB2.Range(ArrZelle(S)) 
                         
                Next 
                 
                WB2.Close False 'Schließen ohne Änderung 
            End If 
        End If 
    Next 
     
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread