Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1688to1692
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Auswertung von Dateiinhalten

Auswertung von Dateiinhalten
24.04.2019 08:39:45
Dateiinhalten
Guten Morgen zusammen.
Jetzt muss ich doch mal etwas Schwarmwissen in Anspruch nehmen... oder das Wissen von jemandem, der sich damit auskennt.
Ich stehe vor folgender Herausforderung.
Ich habe einen Ordner "Einsätze". In dem Verzeichnis liegen die 12 Unterordner "Januar" - "Dezember".
Wiederum in diesen Ordnern unterschiedlich benannte, aber vom Aufbau her identische .xlsm Dateien. ca. 1000 Stk.
Diese Dateien muss ich auswerten.
Heißt, dass ich die Werte aus den Zellen A4, C8, F16 und G9 aus dem Tabellenblatt VM jeweils addieren und in einer Auswertung in die Zellen C4, C9, E4 und M19 schreiben möchte.
Ich hoffe, dass ich hier etwas Support bekomme.
Vielen Dank für eure Bemühungen.
Christoph

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 09:37:17
Dateiinhalten
Hallo Christoph,
teste mal:
Option Explicit
Public Sub Evaluation()
Const FOLDER_PATH As String = "D:\Einsätze\" 'Pfad anpassen !!!
Dim lngMonth As Long
Dim strFileName As String, strMonthFolder As String
Dim objWorkbook As Workbook
Dim enmAutomationSecurity As MsoAutomationSecurity
Dim adblValues(3) As Double
On Error GoTo err_exit
With Application
enmAutomationSecurity = .AutomationSecurity
.AutomationSecurity = msoAutomationSecurityForceDisable
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
For lngMonth = 1 To 12
strMonthFolder = MonthName(Month:=lngMonth) & "\"
strFileName = Dir$(PathName:=FOLDER_PATH & strMonthFolder & "*.xlsm")
Do Until strFileName = vbNullString
Set objWorkbook = GetObject(PathName:=FOLDER_PATH & strMonthFolder & strFileName)
With objWorkbook.Worksheets(1) 'Daten aus der 1. Tabelle eventuell anpassen
adblValues(0) = adblValues(0) + CDbl(.Range("A4").Value)
adblValues(1) = adblValues(1) + CDbl(.Range("C8").Value)
adblValues(2) = adblValues(2) + CDbl(.Range("F16").Value)
adblValues(3) = adblValues(3) + CDbl(.Range("G9").Value)
End With
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
strFileName = Dir$
Loop
Next
With ThisWorkbook.Worksheets("Tabelle1") 'Tabellenname anpassen !!!
.Range("C4").Value = adblValues(0)
.Range("C9").Value = adblValues(0)
.Range("E4").Value = adblValues(0)
.Range("M19").Value = adblValues(0)
End With
sub_exit:
With Application
.AutomationSecurity = enmAutomationSecurity
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
err_exit:
Call MsgBox("Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehlermeldung")
Resume sub_exit
End Sub

Gruß
Nepumuk
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 09:53:44
Dateiinhalten
Ich nochmal,
da ist noch ein Fehler drin. Also so:
Option Explicit
Public Sub Evaluation()
Const FOLDER_PATH As String = "D:\Einsätze\" 'Pfad anpassen !!!
Dim lngMonth As Long
Dim strFileName As String, strMonthFolder As String
Dim objWorkbook As Workbook
Dim enmAutomationSecurity As MsoAutomationSecurity
Dim adblValues(3) As Double
On Error GoTo err_exit
With Application
enmAutomationSecurity = .AutomationSecurity
.AutomationSecurity = msoAutomationSecurityForceDisable
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
For lngMonth = 1 To 12
strMonthFolder = MonthName(Month:=lngMonth) & "\"
strFileName = Dir$(PathName:=FOLDER_PATH & strMonthFolder & "*.xlsm")
Do Until strFileName = vbNullString
Set objWorkbook = GetObject(PathName:=FOLDER_PATH & strMonthFolder & strFileName)
With objWorkbook.Worksheets(1) 'Daten aus der 1. Tabelle eventuell anpassen
adblValues(0) = adblValues(0) + CDbl(.Range("A4").Value)
adblValues(1) = adblValues(1) + CDbl(.Range("C8").Value)
adblValues(2) = adblValues(2) + CDbl(.Range("F16").Value)
adblValues(3) = adblValues(3) + CDbl(.Range("G9").Value)
End With
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
strFileName = Dir$
Loop
Next
With ThisWorkbook.Worksheets("Tabelle1") 'Tabellenname anpassen !!!
.Range("C4").Value = adblValues(0)
.Range("C9").Value = adblValues(1)
.Range("E4").Value = adblValues(2)
.Range("M19").Value = adblValues(3)
End With
sub_exit:
With Application
.AutomationSecurity = enmAutomationSecurity
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
err_exit:
Call MsgBox("Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehlermeldung")
Resume sub_exit
End Sub

Gruß
Nepumuk
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 10:43:54
Dateiinhalten
Oha... schonmal vielen Dank.
Das funktioniert fast.
Allerdings ist das Ergebnis = 0 in allen Zellen.
Beim Einzelschritt Debuggen springt´s von Do Until strFileName = vbNullString direkt zum NEXT.
Könnte an meiner Ordnerbezeichnung liegen. Hatte fälschlicherweise im Jahr 2017 geschaut. Da hießen die tatsächlich Januar bis Dezember. Seit 2018 wurden die Umbenannt und heißen jetzt 01_Jan bis 12_Dez um die eine Sortierung reinzubringen.
Kann man den strMonthFolder = MonthName(Month:=lngMonth) & "\" so abändern, dass eventuell alle Unterordner, egal wie die Bezeichnung ist, berücksichtigt werden?
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 11:13:12
Dateiinhalten
Hallo Christoph,
teste jetzt mal:
Option Explicit

Public Sub Evaluation()
    
    Const FOLDER_PATH As String = "D:\Einsätze\" 'Pfad anpassen !!!
    
    Dim lngMonth As Long
    Dim strFileName As String, strMonthFolder As String
    Dim objWorkbook As Workbook
    Dim enmAutomationSecurity As MsoAutomationSecurity
    Dim adblValues(3) As Double
    
    On Error GoTo err_exit
    
    With Application
        enmAutomationSecurity = .AutomationSecurity
        .AutomationSecurity = msoAutomationSecurityForceDisable
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For lngMonth = 1 To 12
        
        strMonthFolder = Format$(lngMonth, "00") & "_" & _
            MonthName(Month:=lngMonth, Abbreviate:=True) & "\"
        
        strFileName = Dir$(PathName:=FOLDER_PATH & strMonthFolder & "*.xlsm")
        
        Do Until strFileName = vbNullString
            
            Set objWorkbook = GetObject(PathName:=FOLDER_PATH & strMonthFolder & strFileName)
            
            With objWorkbook.Worksheets("VM")
                
                adblValues(0) = adblValues(0) + CDbl(.Range("A4").Value)
                adblValues(1) = adblValues(1) + CDbl(.Range("C8").Value)
                adblValues(2) = adblValues(2) + CDbl(.Range("F16").Value)
                adblValues(3) = adblValues(3) + CDbl(.Range("G9").Value)
                
            End With
            
            Call objWorkbook.Close(SaveChanges:=False)
            
            Set objWorkbook = Nothing
            
            strFileName = Dir$
            
        Loop
    Next
    
    With ThisWorkbook.Worksheets("Tabelle1") 'Tabellenname anpassen !!!
        
        .Range("C4").Value = adblValues(0)
        .Range("C9").Value = adblValues(1)
        .Range("E4").Value = adblValues(2)
        .Range("M19").Value = adblValues(3)
        
    End With
    
    sub_exit:
    
    With Application
        .AutomationSecurity = enmAutomationSecurity
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Exit Sub
    
    err_exit:
    
    Call MsgBox("Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung")
    
    Resume sub_exit
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 09:58:05
Dateiinhalten
Hier auch noch eine Lösung von mir
Option Explicit

Sub Addieren()
    Dim Pfad As String, Monat As String, Datei As String, Ext As String, TB As String
    Dim i As Integer, Anz As Long
    Dim SuC4, SuC9, SuE4, SuM19
    Dim TMP As String
    
    Pfad = "X:\temp\test\Einsätze\"
    Ext = "*.xlsm"
    TB = "VM"
    
    
    For i = 1 To 12 'für Monat... 
        'Verzeichnisname: Januar, Februar... 
        Monat = Format(DateSerial(2019, i, 1), "MMMM") & "\"
        
        Datei = Dir(Pfad & Monat & Ext)
        
        'alle Dateien aus Ordner 
        Do While Len(Datei) > 0
        
            Anz = Anz + 1
            
            'Werte aus geschlossener Datei holen und addieren 
            SuC4 = SuC4 + ExecuteExcel4Macro("'" & Pfad & Monat & "[" & Datei & "]" & TB & "'!" & (Range("A4").Address(ReferenceStyle:=xlR1C1)))
            SuC9 = SuC9 + ExecuteExcel4Macro("'" & Pfad & Monat & "[" & Datei & "]" & TB & "'!" & (Range("C8").Address(ReferenceStyle:=xlR1C1)))
            SuE4 = SuE4 + ExecuteExcel4Macro("'" & Pfad & Monat & "[" & Datei & "]" & TB & "'!" & (Range("F16").Address(ReferenceStyle:=xlR1C1)))
            SuM19 = SuM19 + ExecuteExcel4Macro("'" & Pfad & Monat & "[" & Datei & "]" & TB & "'!" & (Range("G9").Address(ReferenceStyle:=xlR1C1)))
            
            Datei = Dir() ' nächste Datei 
        Loop
    
    Next
    
    'Werte schreiben 
    With ActiveSheet
        .Cells.ClearContents 'reset 
        .Range("C4") = SuC4
        .Range("C9") = SuC9
        .Range("E4") = SuE4
        .Range("M19") = SuM19
    End With
    
    MsgBox Anz & " Dateien ausgelesen!"
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD
Anzeige
AW: Auswertung von Dateiinhalten
24.04.2019 10:57:32
Dateiinhalten
Läuft durch. Allerdings werden 0 Dateien ausgelesen.
Ich glaube es liegt an der falschen Ordnerbezeichnung, die ich gemacht habe.
Die Ordner heißen nicht Januar bis Dezember sondern 01_Jan - 12_Dez
AW: Auswertung von Dateiinhalten
24.04.2019 11:12:42
Dateiinhalten
Hallo nochmal.
dann so...
Option Explicit

Sub Addieren()
    Dim StPfad As String, Monat As String, Datei As String, Ext As String, TB As String
    Dim i As Integer, Anz As Long
    Dim suPfad As String, SuC4, SuC9, SuE4, SuM19
    
    StPfad = "X:\temp\test\Einsätze\"
    Ext = "*.xlsm"
    TB = "VM"
    
    
    For i = 1 To 12 'für Monat... 
        'Verzeichnisname: 01_Jan, 02_Feb... 
        Monat = Format(i, "00") & "_" & Format(DateSerial(2019, i, 1), "MMM") & "\"
        
         
        Datei = Dir(StPfad & Monat & Ext)
        
        'alle Dateien aus Ordner 
        Do While Len(Datei) > 0
        
            Anz = Anz + 1
            
            'Werte aus geschlossener Datei holen und addieren 
            suPfad = "'" & StPfad & Monat & "[" & Datei & "]" & TB & "'!"
            
            SuC4 = SuC4 + ExecuteExcel4Macro(suPfad & Range("A4").Address(ReferenceStyle:=xlR1C1))
            SuC9 = SuC9 + ExecuteExcel4Macro(suPfad & Range("C8").Address(ReferenceStyle:=xlR1C1))
            SuE4 = SuE4 + ExecuteExcel4Macro(suPfad & Range("F16").Address(ReferenceStyle:=xlR1C1))
            SuM19 = SuM19 + ExecuteExcel4Macro(suPfad & Range("G9").Address(ReferenceStyle:=xlR1C1))
            
            Datei = Dir() ' nächste Datei 
        Loop
    
    Next
    
    'Werte schreiben 
    With ActiveSheet
        .Cells.ClearContents 'reset 
        
        .Range("C4") = SuC4
        .Range("C9") = SuC9
        .Range("E4") = SuE4
        .Range("M19") = SuM19
    End With
    
    MsgBox Anz & " Dateien ausgelesen!"
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige