VBA Werte aus anderer Arbeitsmappe beziehen

[Olerostock]

Hi Gast 123,

ja die 0 / 0 Werte sollen mit übernommen werden.

Danke für deine Hilfe und ich teste es später in meiner Grunddatei.

Mit besten Grüßen
Ole

[snb]

Hier reicht:
Vielleicht in D-version : Format(Date, "dd.mm.yyyy")

Code:

Sub M_snb()
  With Workbooks("Varaussage_2025_KW14.xlsx").Sheets("Aussicht").Cells(1).CurrentRegion
    .AutoFilter 1, Format(Date, "dd-mm-yyyy")
    .AutoFilter 4, Array("Verbund1", "Verbund2", "Verbund3"), 7
    .Offset(1).Copy Workbooks("Auswertung Monat April 205.xlsx").Sheets("Aussicht").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    .AutoFilter
  End With
End Sub

[knobbi38]

Kleine Ergänzung:

um die Systemeinstellung mit einzubeziehen, könnte man auch stattdessen:

Code:

.AutoFilter 1, FormatDateTime$(Date,vbShortDate)

verwenden.

Gruß Knobbi38

[Olerostock]

Moin Gast 123,

wenn die Datei aber in einem anderen Ordner liegt, kann ich dann die Datei mit Pfad in C1 einfügen?

Gruß Ole

[Egon12]

Hallo Ole,

dann musst du statt ThisWorkbook.Path & .... den kompletten Pfad der Excel der Variable Pfad zuweisen.

Dazu machst du einen Rechtklick mit gehaltener Shifttaste --> Pfad kopieren.

Dann Pfad = "Dein Pfad"

Den Dateinamen in die Zelle kann man machen, sollte aber in deinen Fall nicht erforderlich sein.

Gruß Uwe

---

Zur Ergänzung:

Die sicherlich gut gemeinte Abfrage in der letzten Zeile nach dem aktuellen Datum kann Probleme bereiten, wenn die Tabelle mal umsortiert bzw. anderweitig manipuliert wird.

So was sollte man via Application.Max() machen.

Dann kann es aber trotzdem noch zu Übernahmelücken kommen, wenn mal Daten zum selben Datum ein 2. Mal ausgelesen werden mussen, weil das 1. mal die Datenlage unvollständig war.

Also diesen Teil besser wieder rausnehmen und besser via "Duplikate entfernen" (Onboard Funktion) aus der Zieltabelle entfernen.

Gruß Uwe

[Olerostock]

Moin Egon 12,

ich habe den Code entsprechend abgeändert, aber

Application.Workbooks.Open (Pfad) erbringt einen Fehler.

Option Explicit
Private arr()


Sub DateiLesen()
Dim Datei$, Pfad$, lz1 As Long
With ThisWorkbook.Sheets("Aussicht")  'ggf. anpassen
    lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(lz1, 1) = Date Then
      MsgBox "Die heutigen Daten sind bereits übertragen!", vbInformation
      Exit Sub
    End If
End With

With ThisWorkbook.Sheets("Makros")
    Datei = .Range("C1").Value
    Pfad = "C:\Users\abc\Downloads" & Datei
    Application.Workbooks.Open (Pfad)
    Application.ScreenUpdating = False
    arr = Workbooks(Datei).Sheets(1).UsedRange.Value
    Application.Workbooks(Datei).Close
    DatenAuslesen
   
    .Range("C4") = Date + Time
    Application.ScreenUpdating = True
End With
End Sub


Private Sub DatenAuslesen()
    Dim i&, j&, k&, arrList(), lz1 As Long
    ReDim arrList(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
    For i = LBound(arr) To UBound(arr)
        If arr(i, 1) = Date And (arr(i, 4) = "Verbund1" Or arr(i, 4) = "Verbund2" Or arr(i, 4) = "Verbund3") Then
            k = k + 1
            For j = LBound(arr, 2) To UBound(arr, 2)
                arrList(k, j) = arr(i, j)
            Next j
        End If
    Next i
    With ThisWorkbook.Sheets("Aussicht")
        lz1 = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lz1, 1).Resize(k, UBound(arrList, 2)) = arrList
    End With
End Sub



Gruß Ole

[Egon12]

Hallo Ole,

es fehlt ein Backslash vor dem Dateinamen.

also so:

Pfad = "C:\Users\abc\Downloads\" & Datei

oder noch simpler:
Pfad = "C:\Users\abc\Downloads\DeineDatei.xlsx"

Das mit der Zelle ist überflüssig

Gruß Uwe

[Gast 123]

Hallo

ich habe deine Frage jetzt erst gesehen, die Lösung ist sehr einfach, s. unten
Ich habe aber noch eine Fehlermeldung neu eingebaut, weil der Wert für k=0 war!
Benutze einfach die Zelle D11 für den Pfad, dann spielt es keine Rolle wo die Datei liegt!

mfg Gast 123

Code:

With ThisWorkbook.Sheets("Makros")
    Pfad = .Range("D1").Value
    Datei = .Range("C1").Value
    If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
    Application.Workbooks.Open (Pfad & Datei)
    Application.ScreenUpdating = False
    arr = Workbooks(Datei).Sheets(1).UsedRange.Value
    Application.Workbooks(Datei).Close
    DatenAuslesen
    .Range("C4") = Date + Time
    Application.ScreenUpdating = True
End With
End Sub


Private Sub DatenAuslesen()
    Dim i&, j&, k&, arrList(), lz1 As Long
    ReDim arrList(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
    For i = LBound(arr) To UBound(arr)
        If arr(i, 1) = Date And (arr(i, 4) = "Verbund1" Or arr(i, 4) = "Verbund2" Or arr(i, 4) = "Verbund3") Then
            k = k + 1
            For j = LBound(arr, 2) To UBound(arr, 2)
                arrList(k, j) = arr(i, j)
            Next j
        End If
    Next i
    '** neu eingefügt wegen Laufzeitfehler bei k=0
    If k = 0 Then MsgBox "Keine Werte für heutiges Datum vorhanden!", vbInformation: Exit Sub
    With ThisWorkbook.Sheets("Aussicht")
        lz1 = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lz1, 1).Resize(k, UBound(arrList, 2)) = arrList
    End With
End Sub

---

Das mit der Zelle ist überflüssig      Ja, wenn der Dateiname IMMER gleich bleibt. Was ist wenn die Monate wechseln???

[Olerostock]

Hi Gast 123,

wenn ich jetzt bei den Daten die kopiert werden sollen "Verbund1", "Verbund2" und "Verbund3" noch Verbund4, Verbund5, Verbund6, Verbund7 und Verbund8 dazukommen, dann reicht es den Code bei dem Arri so zu verlängern?

For i = LBound(arr) To UBound(arr)
        If arr(i, 1) = Date And (arr(i, 4) = "Verbund1" Or arr(i, 4) = "Verbund2" Or arr(i, 4) = "Verbund3" Or arr(i, 4) = "Verbund4" Or arr(i, 4) = "Verbund5" Or arr(i, 4) = "Verbund6" Or arr(i, 4) = "Verbund7" Or arr(i, 4) = "Verbund8" Or arr(i, 4) ) Then
k = k+1


bekomme  nur wieder eine Fehlermeldung

Gruß Ole

[Egon12]

gibt es in der Spalte Verbund, welcher ausgeschlossen werden soll?.

Wenn nein reicht diese Abfrage:

Code:

If arr(i, 1) = Date And InStr(1, arr(i, 4), "Verbund", vbTextCompare) > 0 Then

Gruß Uwe