Clever-Excel-Forum

Hallo,

ich habe mir eine Datei zum automatischen Auslesen bestimmten Zellen erstellt. Funktioniert soweit auch.

Jetzt meine Frage, kann man den Code so vereinfachen, dass ich nur den Ordner angebe in dem die auszulesende Datei liegt und nicht jede Datei extra aufführen muss.

Wenn ich das für ein Jahr machen soll, wird der Code sehr lang.

Vielen Dank

Hallo,

ja, das geht viel kürzer.

Code:
Private Function GetValue(pfad, datei, blatt, zelle)

'** Daten aus geschlossener Arbeitsmappe auslesen

'*** Dimensionierung der Variablen

Dim arg As String

'Sicherstellen, dass das datei vorhanden ist

If Right(pfad, 1) <> "\" Then pfad = pfad & "\"

If Dir(pfad & datei) = "" Then

GetValue = "0"

Exit Function

End If

'** Das Argument erstellen

arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, , xlR1C1)

'** Auslesen über Excel4Macro

GetValue = ExecuteExcel4Macro(arg)

End Function

Sub Zelle_auslesen1()

'** Dimensionierung der Variablen

Dim pfad As String, datei As String, blatt As String, zelle As String

'** Angaben zur auszulesenden Zelle

pfad = "G:\Wasserverteilung\Betriebsdatenprotokolle\2020\6"

datei = "01.06.2020.xls"

blatt = "Gesamtübersicht Teil II"

bezug = "HB32"

'** Eintragen in Zelle

Range("B1").Value = GetValue(pfad, datei, blatt, bezug)

End Sub

Sub Zelle_auslesen2()

'** Dimensionierung der Variablen

Dim pfad As String, datei As String, blatt As String, zelle As String

'** Angaben zur auszulesenden Zelle

pfad = "G:\Wasserverteilung\Betriebsdatenprotokolle\2020\6"

datei = "02.06.2020.xls"

blatt = "Gesamtübersicht Teil II"

bezug = "HB32"

'** Eintragen in Zelle

Range("B2").Value = GetValue(pfad, datei, blatt, bezug)

End Sub

Der Dateiname kann per automatisch generiert werden, der Pfad scheint immer derselbe zu sein.

Pseudocode:

Code:
Start_Datum = #06/01/2020#

for i = 0 to letztes_Datum

Datei_Name = format(Start_Datum + 1, "DD.MM.YYYY") & ".xls"

next i

mfg

Vielen Dank für die schnelle Antwort.

Wo füge ich dann den Pseudocode ein?

Viele Grüße

Ich halte es für unvermeidbar sehr offen zu argumentieren:

Ich hatte genug nach dem Lesen der ersten drei Blöcke und dann vermutet, dass es in diesem Stil weitergeht. Auch kenne ich nicht die Datensturktur.

Vorschlag:

Du lernst

- Schleifen (For ... next)
- Excel Datum (Anzahl der Tage nach 1.1.1900)

Dann sehen wir weiter.

Hier ein Versuch Deinen Code etwas zu kürzen. Da ich es nicht prüfen kann, können einige Fehler enthalten sein, Also bitte sorgfältig debuggen:

Code:
const Base as string = "G:\Wasserverteilung\Betriebsdatenprotokolle\2020\"

const Blatt as string = "Gesamtübersicht Teil II"

const Bezug as string = "HB32"

Private Function GetValue(pfad, datei, blatt, zelle)

'** Daten aus geschlossener Arbeitsmappe auslesen

'*** Dimensionierung der Variablen

Dim arg As String

'Sicherstellen, dass das datei vorhanden ist

If Right(pfad, 1) <> "\" Then pfad = pfad & "\"

If Dir(pfad & datei) = "" Then

GetValue = "0"

Exit Function

End If

'** Das Argument erstellen

arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, , xlR1C1)

'** Auslesen über Excel4Macro

GetValue = ExecuteExcel4Macro(arg)

End Function

sub Auslesen()

for i = cdate("1.6.2020") to cdate("31.8.2020")

    lr = lr + 1

    Pfad = Base & month(i)

    Datei = format(i), "DD.MM.YYYY") & ".xls"

    cells(lr, 1) = i

    cells(lr, 2) = GetValue(Pfad, Datei, Blatt, Bezug)

next i

end sub

Dies sollte den kompletten in der Beispieldatei enthaltenen Code ersetzen.

Hallo

Ich habe es so gelöst.

Du kannst den Monat und das Jahr angeben.
Dann wird ein Blatt z.B. 08.2020 gesucht oder neu angelegt.

Für jeden Tag des Monats (Monatsende wird ermittelt) wird dort ein Eintrag erstellt und der Wert aus der entsprechenden Datei gelesen

in ein Modul.

Code:
Option Explicit

Sub Wasser()

    Dim TB As Worksheet

    Dim iMonat As Integer, iJahr As Integer

    Dim iETag As Date, iLTag As Date, i As Date

    Dim Pfad As String, GPfad As String, Datei As String, Blatt As String, Bezug As String

    Dim Ext As String, BlName As String

    Dim JaNein As Variant, Wert As Variant

    Pfad = "E:\Excel\temp\Wasserverteilung\Betriebsdatenprotokolle\" 'MIT \ am Ende

    Ext = ".xlsx"

    Blatt = "Gesamtübersicht Teil II"

    Bezug = "HB32"

    iMonat = InputBox("Monat", , Month(Date))

    iJahr = InputBox("Jahr", , Year(Date))

    iETag = DateSerial(iJahr, iMonat, 1) ' Erster Tag das aktuellen Monats

    iLTag = DateSerial(iJahr, iMonat + 1, 0) ' Letzter Tag des aktuellen Monats

    GPfad = Pfad & iJahr & "\" & iMonat & "\" 'Gesamtpfad

    BlName = Format(iMonat, "00") & "." & iJahr

    'Prüfen, ob Blatt schon vorhanden ist

    If IsError(Evaluate(BlName & "!A1")) Then

        'Neues Blatt für aktuellen Monat anlegen und benennen

        Set TB = Sheets.Add(After:=Sheets(Sheets.Count))

        TB.Name = BlName

    Else

        Set TB = Sheets(BlName)

        TB.Cells.Clear

    End If

    'Daten für jeden Tag des Monats lesen

    For i = iETag To iLTag

        Datei = GPfad & i & Ext

        Wert = GetValue(GPfad, i & Ext, Blatt, Bezug)

        If Wert <> "##" Then

            TB.Cells(Day(i), 1) = i

            TB.Cells(Day(i), 2) = Wert

        Else

            'Datei nicht vorhanden

            JaNein = MsgBox("Datei: '" & i & Ext & "' ist im Verzeichnis:" & vbLf & _

                GPfad & vbLf & "nicht vorhanden", vbExclamation + vbOKOnly)

            Exit Sub

        End If

    Next

End Sub

Private Function GetValue(Pfad, Datei, Blatt, Zelle)

    '** Daten aus geschlossener Arbeitsmappe auslesen

    '*** Dimensionierung der Variablen

    Dim arg As String

    'Sicherstellen, dass das datei vorhanden ist

    If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"

    If Dir(Pfad & Datei) = "" Then

        GetValue = "##"

        Exit Function

    End If

    '** Das Argument erstellen

    arg = "'" & Pfad & "[" & Datei & "]" & Blatt & "'!" & Range(Zelle).Range("A1").Address(, , xlR1C1)

    '** Auslesen über Excel4Macro

    GetValue = ExecuteExcel4Macro(arg)

End Function

LG UweD

matthes

Fennek

matthes

Fennek

Fennek

UweD