Summen aus mehreren Dateien in eine neue Tabelle schreiben

Question

Hallo zusammen,

ich habe ein kleines Problem und hoffe das ihr mir helfen könnt. Ich habe mir in Netz schon einen VBA Code besorgt, der eigentlich auch ganz gut funktioniert. Nur habe ich ein Problem, da die Summenzeile immer an einer anderen Stelle ist. Daher müsste nach dem Wort "Summe" gesucht und der Wert der in der J Spalte steht ausgegeben werden.

Könnte ihr mir helfen?

Viele Grüße

Fridolin

Hier mal der bisher verwendete Code:

Public Sub TabNeu()

    Dim sPfad As String
    Dim sDatei As String

    Dim sBlatt As String
    Dim aZellAdresse() As Variant, iZA As Long
    Dim aErgebnis() As Variant, iE As Long
        
    sBlatt = "Tabelle1"              
    aZellAdresse() = Array("J9", "J38", "J39", "J40", "J37", "J36")  
    
    
    'Schritt 1: Schleife über alle Excel Dateien in einem Verzeichnis
    sPfad = "C:\Rechnungen\"
    sDatei = Dir(CStr(sPfad & "*.xlsx"))
    
    Do While sDatei <> ""
                                    
        iE = iE + 1
        ReDim Preserve aErgebnis(1 To UBound(aZellAdresse) + 2, 1 To iE)
        
        aErgebnis(1, iE) = sDatei
        For iZA = LBound(aZellAdresse) To UBound(aZellAdresse)
            aErgebnis(iZA + 2, iE) = "='" & sPfad & "[" & sDatei & "]" & sBlatt & "'!" & aZellAdresse(iZA)
        Next
    
        'Nächste Datei
        sDatei = Dir()
    
    Loop
        
    If iE > 0 Then
        
        Application.ScreenUpdating = False 'Das "Flackern" ausstellen
        
        'Schritt 2: Neues Arbeitsblatt für die Ergebnisse erstellen
        With ThisWorkbook.Worksheets("Tabelle1")
            With .Range("A2").Resize(UBound(aErgebnis, 2), UBound(aErgebnis, 1))
                .Formula = WorksheetFunction.Transpose(aErgebnis)
                .Formula = .Value
            End With
        End With
        
        Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
        
    End If
    
End Sub

Answer 1

Hallo Fridolin,

steht das Wort Summe in einer bestimmten Spalte? Falls nicht, kommt das Wort Summe dann nur einmal im Blatt vor?

Gruß

M.O.

Answer 2

Hallo M.O.

ja, Summe kommt nur einmal im Blatt vor.

Gruß Fridolin

Answer 3

Hallo Fridolin,

da das Wort Summe in den einzelnen Dateien gesucht werden soll, müssen die Dateien geöffnet werden. Deshalb dauert die Ausführung des Makros auch etwas länger. In Tabelle1 der Arbeitsmappe, aus der das Makro gestartet wird, wird in Spalte A der Name der geöffneten Arbeitsmappe und in Spalte B der Wert der Summe aus Spalte J eingetragen, und in Spalte C die entsprechende Verknüpfung, wie in deinem vorhandenen Makro. Du kannst dir aussuchen, was dir lieber ist. In den zu öffnenden Arbeitsmappen wird immer im Arbeitsblatt "Tabelle1" nach dem Wert gesucht.

Sub Einlesen()
Dim sPfad As String
Dim sDatei As String
Dim rngErgebnis As Range
Dim lngZeile As Long

 
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'letzte beschriebene Zeile in Tabelle 1 dieser Arbeitsmappe ermitteln
lngZeile = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
   
'Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "C:\Rechnungen\"
sDatei = Dir(CStr(sPfad & "*.xlsx"))
    
'alle xlsx-Dateien in dem Verzeichnis durchlaufen und öffnen
Do While sDatei <> ""
  'Arbeitsmappe nur dann öffnen, wenn es nicht diese Arbeitsmappe ist
  If ThisWorkbook.Name <> sDatei Then
    'Datei öffnen
     Workbooks.Open Filename:=sPfad & sDatei
    'nun das Wort Summe suchen
    Set rngErgebnis = Workbooks(sDatei).Worksheets("Tabelle1").UsedRange.Find("Summe", LookIn:=xlValues)
    'falls etwas gefunden wurde, dann Verknüpfung zu Spalte J der Ergebniszeile erstellen
    If Not rngErgebnis Is Nothing Then
      'Einfügezeile erhöhen
      lngZeile = lngZeile + 1
      With ThisWorkbook.Worksheets("Tabelle1")
        .Cells(lngZeile, 1) = sDatei
        .Cells(lngZeile, 2) = Workbooks(sDatei).Worksheets("Tabelle1").Cells(rngErgebnis.Row, 10).Value    'hier wird der Wert in Spalte B eingetragen
        .Cells(lngZeile, 3).FormulaLocal = "='" & sPfad & "[" & sDatei & "]Tabelle1'!J" & rngErgebnis.Row  'hier wird die Verknüpfung in Spalte C eingetragen
      End With
      'geöffnete Datei wieder ohne speichern schließen
      Workbooks(sDatei).Close (False)
      'und rngErgebnis zurück setzen
      Set rngErgebnis = Nothing
    End If
  End If
  'Nächste Datei
  sDatei = Dir()
Loop
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 4

Hallo M.O.

jetzt bin ich dazu gekommen. Funktioniert Super, tut genau das was er soll.

Aber nicht bei allen. Mir ist aufgefallen, dass bei denen wo das Wort "Summe" in Spalte A steht nicht gefunden wird. Sobald Spalte A eine Leerspalte ist, findet er das Wort und fügt alles korrekt ein. Achso, würde es gehen die Spalte I9 ebenfalls mit abzufragen?

Viele Grüße

Fridolin

Answer 5

Hallo Fridolin,

bei meinen Test mit dem Makro wird der Betrag aus den Testdateien korrekt importiert, egal in welcher Spalte das Wort "Summe" steht. Steht in den Fällen, bei denen nichts eingefügt wird, auch ein Wert in Spalte J der betreffenden Zeile?

Wenn du noch den Wert aus der Zelle I9 importiert haben willst, dann ändere die Zeile

.Cells(lngZeile, 3).FormulaLocal = "='" & sPfad & "[" & sDatei & "]Tabelle1'!J" & rngErgebnis.Row  'hier wird die Verknüpfung in Spalte C eingetragen

in

.Cells(lngZeile, 3) = Workbooks(sDatei).Worksheets("Tabelle1").Range("I9").Value    'hier wird der Wert aus Zelle I9 in Spalte C eingetragen

Gruß

M.O.