Code vereinfachen

[matthes]

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

[Fennek]

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

[matthes]

Vielen Dank für die schnelle Antwort.

Wo füge ich dann den Pseudocode ein?



Viele Grüße

[Fennek]

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.

[Fennek]

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.

[UweD]

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