thiesk
Goto Top

Wie einzelne Zellen aus mehreren Excel-Dateien auslesen und in eine neue Datei einfügen?

Hallo liebes Forum,

nach stundenlanger Suche im Internet und keiner wirklich gefundenen Lösung hoffe ich, dass hier mir jemand helfen kann.
Für die Arbeit soll ich aus vielen Excel-Dateien eine Auswertung vornehmen. Ich dachte mir am Besten per Makro/VBA. Da ich mich damit jedoch nicht so gut auskenne, hoffte ich ein bestehendes Programm umzuschreiben, was jedoch scheiterte..

Die einzelnen Excel-Dateien sehen so aus, dass immer aus der "Tabelle1" die Informationen aus den Zellen "B28", "E28", "H28", "O28", "Q28", "A30", "A31" ausgelesen und dann ab der 3.Zeile (Die ersten beiden Zeilen sollen für Überschriften da sein) spaltenweise eingefügt werden sollen. Also: Alle Werte von "B28" untereinander, alle Werte von "E28" untereinander, etc.

Für eure Unterstützung wäre ich euch sehr sehr dankbar!

Ich nutze Excel 2007 und Win XP. Falls ihr noch weitere Fragen habt, werde ich sie schnellstmöglichst beantworten!

Vielen Dank noch einmal!

Gruß ThiesK

Content-Key: 188712

Url: https://administrator.de/contentid/188712

Ausgedruckt am: 28.03.2024 um 23:03 Uhr

Mitglied: Eierbaer
Eierbaer 27.07.2012 um 14:27:40 Uhr
Goto Top
Hallo ThiesK,

probiers einmal hiermit, muss Du natürlich etwas anpassen, aber funktioniert:

Option Explicit

Public Sub ExcelDateienAuswerten()

    Dim strDateiname As String
    Dim strPfad      As String
    Dim lngZeile     As Long
    
    'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen  
    strPfad = "F:\Projekte\Administrator.de\Quelle\"  
    
    'Den 1. Dateinamen holen  
    strDateiname = Dir(strPfad & "*.xls")  

    'Startzeile festlegen  
    lngZeile = 3
    
    'Solange ein Dateiname gelesen wird  
    Do While Not strDateiname = ""  
        
        'Datei verarbeiten  
        Call TabVerarb(strPfad & strDateiname, lngZeile)
        
        'nächsten Dateinamen holen  
        strDateiname = Dir()
        
        'Zeilenzähler erhöhen  
        lngZeile = lngZeile + 1
     Loop

End Sub



Public Sub TabVerarb(strPfad As String, lngZeile As Long)
    Dim strMeSH As String
    Dim strDatei As String
    Dim strSH As String
    
    'Dateinamen extrahieren  
    strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))  
    
    'Eigenen Namen merken  
    strMeSH = ActiveWorkbook.Name
    
    'Datei öffnen  
    Workbooks.Open Filename:=strPfad
    
    With Workbooks(strMeSH)
        'Dateinamen und auszuwertenden Zellen übertragen  
        .Sheets("Tabelle1").Cells(lngZeile, 1) = strDatei  
        .Sheets("Tabelle1").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("Tabelle1").Range("B28").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("Tabelle1").Range("E28").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("Tabelle1").Range("H28").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 5) = Workbooks(strDatei).Sheets("Tabelle1").Range("O28").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 6) = Workbooks(strDatei).Sheets("Tabelle1").Range("Q28").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 7) = Workbooks(strDatei).Sheets("Tabelle1").Range("A30").Value  
        .Sheets("Tabelle1").Cells(lngZeile, 8) = Workbooks(strDatei).Sheets("Tabelle1").Range("A31").Value  
    End With
    
    'Quelldatei schließen  
    Workbooks(strDatei).Saved = True
    Workbooks(strDatei).Close

End Sub


Gruß
Rüdiger aus Minden
Mitglied: 76109
76109 27.07.2012 aktualisiert um 16:39:59 Uhr
Goto Top
Hallo ThiesK!

Oder so:
Option Explicit

Const sXlsPath = "D:\Temp"  
Const iStartZeile = 3
Const iStartSpalte = 1

Const Zellen = "B28,E28,H28,O28,Q28,A30,A31"  


Sub CopyExternData()
    Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
    Dim aCells As Variant, iNextLine As Long, i As Integer
    
    Set oWks0 = ThisWorkbook.ActiveSheet
    
    aCells = Split(Zellen, ","):  iNextLine = iStartZeile  
    
    Set oFso = CreateObject("Scripting.FilesystemObject")  
    
    For Each oFile In oFso.GetFolder(sXlsPath).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "xls" Then  
            If ThisWorkbook.Name <> oFile.Name Then
                Set oWkb1 = Workbooks.Open(oFile.Path)
                Set oWks1 = oWkb1.Sheets(1)
                For i = 0 To UBound(aCells)
                    oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells(i))).Value
                Next
                oWkb1.Close False
                iNextLine = iNextLine + 1
            End If
        End If
    Next
End Sub

Gruß Dieter

[edit] Hatte doch was übersehen (ThisWorkbook.Path anstatt .Name) [/edit]
Mitglied: ThiesK
ThiesK 27.07.2012 um 15:16:18 Uhr
Goto Top
Hallo Rüdiger,

vielen vielen Dank für deine Mühe und verständnisvolle Kommentargebung im Programm. Du hast mir sehr geholfen, dass Programm arbeitet einwandfrei! Als gelernter Nutzer der "C"-Programmierung, konnte ich das Programm jetzt gut nachvollziehen und die Arbeitsweise verstehen! Zwischenzeitlich hatte ich mir aus vielen verschiedenen Programmteilen aus diesem Forum ein eigenes Programm geschrieben, dieses hatte jedoch etliche Bugs...

Also nochmal: Vielen Dank für deine Mühe. Ich hoffe auch andere Nutzer mit einem ähnlichen Problem können hieraus schöpfen

Grüße
Thies
Mitglied: bastla
bastla 27.07.2012 um 15:31:11 Uhr
Goto Top
[OT] @Dieter
Irgendwie vermisse ich noch die "Union()"-Variante .. face-wink

Grüße
bastla
[/OT]
Mitglied: ThiesK
ThiesK 27.07.2012 um 15:52:17 Uhr
Goto Top
Ja, ich habe diese Version auch noch einmal ausprobiert, aber da kommt das Programm in eine Endlosschleife... Trotzdem vielen Dank für die Mühe, Dieter, auch wenns noch nicht 100%ig hinhaut, weiß ich das zu schätzen!

Grüße
Thies
Mitglied: 76109
76109 27.07.2012 aktualisiert um 16:20:58 Uhr
Goto Top
[OT]
Hallo bastla!

Die hatte ich auch zuerst im Auge gehabt, aber das funktioniert in der Regel nur, wenn sich alle Werte in der gleichen Zeile befinden. Ansonsten geht's über Areas und da werden alle Werte die auseinanderliegen in ein Item und die Werte, die zusammen liegen (A30, A31) werden als Array in Item übernommenface-wink

Gruß Dieter
[/OT]
Mitglied: 76109
76109 27.07.2012 aktualisiert um 16:41:27 Uhr
Goto Top
Hallo Thies!

Endlosschleife, wie das?


Gruß Dieter


PS. Oben geändert: Von ThisWorkbook.Path nach ThisWorkbook.Name...
Mitglied: beggagsell
beggagsell 05.02.2013 um 09:57:54 Uhr
Goto Top
Hallo zusammen,
ich bin neu im Bereich VB Programmierung und habe mir die Lösung hier angeschaut. Die trifft meine eigene Anforderung fast genau.

Meine Frage: Wie kann ich es hinterlegen, dass weitere Daten über eine Schleife wiederholdend aus einem Arbeitsblatt ausgelesen und die ausgelesenen Werte untereinander dargestellt werden?

B28,E28,H28,O28,Q28,A30,A31
B128,E128,H128,O128,Q128,A130,A131
B228,E228,H228,O228,Q228,A230,A231
(500 Auswertungen, die Zeilenabstände erhöhen sich jeweils um 100)


Liebe Grüße

Beggagsell
Mitglied: 76109
76109 23.02.2013 aktualisiert um 11:40:43 Uhr
Goto Top
Hallo Beggagsell!

Hatte leider wenig Zeit, von daher etwas verspätetface-wink in etwa so:
Option Explicit

Const sXlsPath = "D:\Temp"  
Const iStartZeile = 3           'Diese Arbeitsmappe, Daten ab Zeile  
Const iStartSpalte = 1          'Diese Arbeitsmappe, Daten ab Spalte  

Const iStartCopyZeile = 28      'Externe Arbeitsmappe,Daten ab Zeile (28)  
Const iNextCopyZeile = 100      'Externe Arbeitsmappe,Daten nächste Zeile (+100)  

Sub CopyExternData2()
    Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
    Dim aOfs As Variant, oNextCell As Range, iNextLine As Long, i As Integer
    
    Set oWks0 = ThisWorkbook.ActiveSheet
    Set oFso = CreateObject("Scripting.FilesystemObject")  
    
    'Relative Offset-Adressen (Aktuelle Zeile + ?, Spalte 1 + ?)  
    'Bei aktueller Zeile 28 entspricht dies: B28, E28, H28, O28, Q28, A30, A31  
    aOfs = Array(Array(0, 1), _
                 Array(0, 4), _
                 Array(0, 7), _
                 Array(0, 14), _
                 Array(0, 16), _
                 Array(2, 0), _
                 Array(2, 0))
    
    iNextLine = iStartZeile
    
    Application.ScreenUpdating = False
    
    For Each oFile In oFso.GetFolder(sXlsPath).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "xls" Then  
            If ThisWorkbook.Name <> oFile.Name Then
                Set oWkb1 = Workbooks.Open(oFile.Path)
                Set oWks1 = oWkb1.Sheets(1)
                
                'Set Bezugs-Zelle (Bei Zeile 28: A28)  
                Set oNextCell = oWks1.Cells(iStartCopyZeile, "A")  
                
                'Daten kopieren, solange Zelle (B28, B128, ...) mit Inhalt  
                Do While oNextCell.Offset(aOfs(0)(0), aOfs(0)(1)).Text <> ""  
                    For i = 0 To UBound(aOfs)
                        oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = oNextCell.Offset(aOfs(i)(0), aOfs(i)(1)).Value       
                    Next
                    
                    'Set Next Bezugs-Zelle + 100 Zeilen (A128, A228, ...)  
                    Set oNextCell = oNextCell.Offset(iNextCopyZeile, 0):  iNextLine = iNextLine + 1
                Loop
                oWkb1.Close False
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Gruß Dieter
Mitglied: beggagsell
beggagsell 26.02.2013 um 13:50:44 Uhr
Goto Top
Hallo Dieter,

Danke für die Information.
Leider funktioniert das Makro nicht.
Es wird zwar die Datei in c:\temp geöffnet, aber kein Wert in die Zieltabelle geschrieben.
Die einzige Änderung die ich vornehme ist die Umstellung auf c:\temp
Könntest du noch mal drüberschauen - wäre echt super.

Danke

Beggagsell
Mitglied: 76109
76109 27.02.2013 aktualisiert um 00:18:50 Uhr
Goto Top
Hallo Beggagsell!

Sorry, bei mir funktionierts?

Befinden sich die Daten im ersten Tabellenblatt und stimmen die Basis-Zellen (B28, E28, H28, O28, Q28, A30, A31) überein. Ausserdem dürfen die Bezugszellen (B28, B128, B...) nicht leer sein...

Gruß Dieter
Mitglied: beggagsell
beggagsell 27.02.2013 um 15:41:32 Uhr
Goto Top
Hallo Dieter,
so ist das nun mal...
Wenn man die Datei nicht mit der Endung xlsx speichert, klappt das besser. (geöffnet wurde eine andere Datei im Verzeichnis ohne Daten in den jeweiligen Feldern)

Du hast mir mehrere Stunden mit meiner Freundin verschafft, die ich sonst am PC verbracht hätte.

Herzlichen Dank - eine Top Lösung.
Mitglied: HC-Ahnungslos
HC-Ahnungslos 18.12.2015 aktualisiert um 19:20:05 Uhr
Goto Top
Einen schönen guten Tag Rüdiger,
ich habe dein Codefragment (erste Lösung) gefunden und nach der Beschreibung passt es perfekt auf meine Bedürfnisse. Leider bin ich ein VBA Laie und kriege es nicht ganz zum laufen. Ich kriege immer den gleichen Fehler 68. in Zeile 13 bei Dir. ich nutze Excel auf dem Mac, könnte es daran liegen? grundsätzlich habe ich eigentlich nur das .xls in .xlsx geändert da ich mit eben diesen Dateien arbeite.

Für einen Tipp wäre ich wirklich sehr dankbar!
Einen schönen Abend noch

Gruß
HC
Mitglied: pplifr
pplifr 23.08.2017 um 16:54:44 Uhr
Goto Top
Hallo@all,

habe die Lösung von Dieter jetzt adaptiert und funktioniert fast so genau so wie ich will.
Habe aber sehr viele Files welche ich wöchentlich auslesen muss.
Das Makro öffnet ja jedes File.
Das dauert leider zu lange. In dem Ordner befinden sich Prüfprotokolle vom ganzen Jahr (1000+)
Ich muss aus Prüfprotokollen immer 12 idente Zellen auslesen, welche wir dann gelistet in Power BI auswerten.
Prüfprotokoll kann ich leider nicht anpassen, somit brauche ich diesen Zwischenschritt über ein auswertbares File.

*
Const sXlsPath = "G:\QUALITÄTSSICHERUNG\AUSW_TEST"
Const iStartZeile = 5
Const iStartSpalte = 1
Const Zellen = "F1,E3,E8,E9,E10,E11,I8,I9,I10,I11,I12,I13"
***
Bin leider ein absoluter DAU bei Excel und speziell bei VBA.

Vielleicht kann mir ja wer helfen

Danke vorab

Markus
Mitglied: Aston01
Aston01 24.10.2017 um 11:51:03 Uhr
Goto Top
Hallo
Ich bekomme täglich 50 Mails mit je einer xlsx Datei. Diese heissen immer gleich und zwar order.xlsx. Nun möchte mit einem Makro alle xlsx Files durchgehen die in einem bestimmten Ordner sind und überprüfen, ob das Datum in der Zelle … z.B 24-10-2017 mit dem Namen eines erstellten xlsx. file übereinstimmt, welches den Namen z.B UC -Rondo-Safe-(hier kommt dann ein Datum rein) hat. Wenn dies zutrifft, sollen nun die ganzen Werte aus dieser Datei in die erstellte Datei eingefügt werden.
Ich hoffe das mir jemand bei diesem Problem helfen kann, weil ich verzweifelt nach einer Lösung suche.
LG