Aus mehreren Excel-Dateien Daten auslesen und in eine Excel Datei einfügen - Batch

Nachdem mir hier schon einmal geholfen wurde, möchte ich erneut um Eure Hilfe für einen Batch bieten.

Folgendes Szenario:

Auf Laufwerk Z habe ich einen Ordner Exceldateien mit mehreren hundert Exceldateien (#-Z sortiert).
Ich möchte nun gerne die Information in der Spalte J2 aller dieser Exceldateien in ein neues Excel-Sheet "Excel-Gesamt" (noch nicht erstellt) einfügen und zwar folgendermassen:
- Zeile/Spalte A1 - den Namen der Exceldatei
- Zeile/Spalte A2 - die Information aus J2
Danach B1 und B2 usw. bis alle Excel-Dateien durchgearbeitet sind.
Es kann auch vorkommen das keine Informationen in J2 vorhanden sind, dann soll das Script nur A1 ausfüllen und A2 leer lassen.
Exceldateien sollen nach Abarbeitung nicht gelöscht werden.

Optional (kann man sonst auch im Excel erledigen) wäre es noch von Vorteil wenn beim Einfügen der Informationen folgende Bearbeitung vorgenommen werden könnte:
Die Infos aus J2 sollten noch gesplitten werden.
Abenteuer / Komödie = Abenteuer (in A2) , Komödie (in A3)
Abenteuer / Komödie / Fantasy = Abenteuer (in A2) , Komödie (in A3) , Fantasy (in A4)
(Max. 4 Spalten)
Ausnahme: Der Begriff Horror/Grusel sollte als ein Begriff erkannt werden (keine Leerzeichen vor und nach dem Slash)
(Ich arbeite noch mit der XP-Version von Excel)

Auch hier wäre ich sehr dankbar für Eure Unterstützung.

Liebe Grüsse

Legolegolas

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 254755

Url: https://administrator.de/forum/aus-mehreren-excel-dateien-daten-auslesen-und-in-eine-excel-datei-einfuegen-batch-254755.html

Ausgedruckt am: 19.02.2025 um 22:02 Uhr

7 Kommentare

Neuester Kommentar

Hallo Legolegolas,

Batch kann keine Exceldaten verarbeiten. Mit anderen Scriptsprachen (z.B. VBScript) wäre das denkbar, falls du diese beherrscht und Excel installiert ist.

Grüße
rubberman

Danke rubberman

VBScript beherrsche ich leider nicht. Dann muss ich mir was anderes einfallen lassen.

Grüße
Legolegolas

Ich habe ein VBScript im Netz gefunden und es soweit angepasst, dass es meine Grundwünsche erfüllt.

Kannst Du mir bei der Option helfen ?

Option Explicit

Const Bereich = "J2"  

Const OrdnerPfad = "z:\Excel\"  

Dim xls_Appl                              ' Excel Programm  

Dim xls_Mappe                             ' Excel Arbeitsmappe  
Dim xls_Blatt                             ' Excel Tabelle  

Dim xls_Mappe1                             ' Excel Arbeitsmappe  
Dim xls_Blatt1                             ' Excel Tabelle  

Dim fso                                 ' FileSystemObject  
Dim fo                                   ' Ordner (Folder)  
Dim fi                                    ' Datei (File)  

Dim Zeile
Dim Spalte

Set fso = CreateObject("Scripting.FileSystemObject")  
Set fo = fso.GetFolder(OrdnerPfad)

' ***** Excel starten *****  
Set xls_Appl= CreateObject("Excel.Application")  
xls_Appl.Visible = True            ' Excel sichtbar  

Set xls_Mappe = xls_Appl.Workbooks.Add(1) ' Leeres Tabellenblatt hinzufügen  
Set xls_Blatt = xls_Mappe.Worksheets(1)    

Zeile = 1
Spalte = 1
For Each fi In fo.Files            ' Alle Dateien im Ordner durchlaufen  

    If Right(UCase(fi.Name),3) ="XLS" Then        ' Erkennen der Excel-Dateien  
        Set xls_Mappe1 = xls_Appl.Workbooks.Open(OrdnerPfad & fi.Name)
        Set xls_Blatt1 = xls_Mappe1.Worksheets(1)
        ' *****  
        xls_Blatt.Activate
        xls_Blatt.Range("A" & Zeile).Select    ' Aktive Zelle auswählen  
        xls_Appl.ActiveCell.Value = fi.Name    ' Dateiname als Überschrift  
        Zeile = Zeile + 1

        xls_Blatt1.Activate
        xls_Blatt1.Range(Bereich).Select    ' Bereich auswählen  
        xls_Appl.Selection.Copy

        xls_Blatt.Activate
        xls_Blatt.Range("B" & Spalte).Select    ' Aktive Zelle auswählen  
        xls_Mappe.ActiveSheet.Paste
        Spalte = Spalte + 1
        ' *****  
        xls_Mappe1.Close            ' Eingabe wieder schließen  
        Set xls_Blatt1 = Nothing        ' Resourcen freigeben  
        Set xls_Mappe1 = Nothing
    End If
Next

xls_Mappe.Saveas (OrdnerPfad & "ExcelNeu.xls")        ' Tabelle speichern  
xls_Appl.Quit                         ' Excel beenden  

Set fi = Nothing                    ' Resourcen wieder freigeben  
Set fo = Nothing
Set fso = Nothing

Set xls_Blatt = Nothing
Set xls_Mappe = Nothing
Set xls_Appl = Nothing

Hallo Legolegolas,

ich denke so sollte es funktionieren.

Option Explicit

Const strPath  = "Z:\Excel"  
Const strFile  = "Excel-Gesamt.xls"  
Const strRange = "J2"  

Dim objFSO, objFolder, objFile, _
    objExcelApp, objThisWB, objThisWS, objWB, _
    strXls, strRead, arrRead, i, j

Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strPath)
strXls = objFSO.BuildPath(strPath, strFile)
If objFSO.FileExists(strXls) Then objFSO.DeleteFile strXls, True

Set objExcelApp = CreateObject("Excel.Application")  
Set objThisWB = objExcelApp.Workbooks.Add
Set objThisWS = objThisWB.Worksheets(1)

i = 1
For Each objFile In objFolder.Files
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then  
    Set objWB = objExcelApp.Workbooks.Open(objFile.Path, 0, True)
    strRead = objWB.Worksheets(1).Range(strRange)
    arrRead = Split(Replace(strRead, " / ", "$"), "$")  
    objThisWS.Cells(i, 1) = objWB.Name
    If IsArray(arrRead) Then
      For j = 0 To UBound(arrRead)
        objThisWS.Cells(i, j + 2) = arrRead(j)
      Next
    End If
    objWB.Close False
    i = i + 1
  End If
Next

objThisWB.SaveAs strXls
objExcelApp.Quit

Grüße
rubberman

Tag rubberman

Das funktioniert wieder auf Anhieb - Klasse.
Ich wollte Dir noch sagen, dass ich schon mehrere Stunden an deinem ersten Script herum studiert habe. Unterdessen verstehe ich auch so einiges, aber sind wir ehrlich, das alles ist nicht gerade einfach und braucht viel Übung. Auch dieses Script ist wieder "Bahnhof" für mich.
Ich wünschte mir, dass ich das auch so locker aus dem Handgelenk schütteln könnte - ich danke Dir.

Grüße

Legolegolas

Hallo Legolegolas.

Ich wünschte mir, dass ich das auch so locker aus dem Handgelenk schütteln könnte

Wenn du dich lang genug damit beschäftigst, wird das passieren. Schau dir Beispiele und Referenzen an. Im MSDN sind Windows-Scriptsprachen sehr detailliert dokumentiert.
Hier noch einmal das Script mit den entsprechenden Links. Wirf auf den verlinkten Seiten auch mal einen Blick auf das linke Sidebar, dann erkennst du wie du dich entlang hangeln kannst, um zu finden was du suchst ...

' http://msdn.microsoft.com/en-us/library/bw9t3484(v=vs.84).aspx  
Option Explicit

' http://msdn.microsoft.com/en-us/library/16twy8ed(v=vs.84).aspx  
Const strPath  = "Z:\Excel"  
Const strFile  = "Excel-Gesamt.xls"  
Const strRange = "J2"  

' http://msdn.microsoft.com/en-us/library/zexdsyc0(v=vs.84).aspx  
Dim objFSO, objFolder, objFile, _
    objExcelApp, objThisWB, objThisWS, objWB, _
    strXls, strRead, arrRead, i, j

' "Set" statement:  
' http://msdn.microsoft.com/en-us/library/4afksd44(v=vs.84).aspx  

' http://msdn.microsoft.com/en-us/library/z9ty6h50(v=vs.84).aspx  
Set objFSO = CreateObject("Scripting.FileSystemObject")  
' http://msdn.microsoft.com/en-us/library/f1xtf7ta(v=vs.84).aspx  
Set objFolder = objFSO.GetFolder(strPath)
' http://msdn.microsoft.com/en-us/library/z0z2z1zt(v=vs.84).aspx  
strXls = objFSO.BuildPath(strPath, strFile)
' http://msdn.microsoft.com/en-us/library/5h27x7e9(v=vs.84).aspx  
' http://msdn.microsoft.com/en-us/library/x23stk5t(v=vs.84).aspx  
' http://msdn.microsoft.com/en-us/library/thx0f315(v=vs.84).aspx  
If objFSO.FileExists(strXls) Then objFSO.DeleteFile strXls, True

' http://msdn.microsoft.com/en-us/library/ms974573.aspx  
Set objExcelApp = CreateObject("Excel.Application")  
' http://msdn.microsoft.com/en-us/library/office/ff820765(v=office.15).aspx  
' http://msdn.microsoft.com/en-us/library/office/ff840478(v=office.15).aspx  
Set objThisWB = objExcelApp.Workbooks.Add
' http://msdn.microsoft.com/en-us/library/office/ff840672(v=office.15).aspx  
Set objThisWS = objThisWB.Worksheets(1)

i = 1
' http://msdn.microsoft.com/en-us/library/tywtbxd0(v=vs.84).aspx  
' http://msdn.microsoft.com/en-us/library/1ft05taf(v=vs.84).aspx  
' http://msdn.microsoft.com/en-us/library/wz72a8c0(v=vs.84).aspx  
For Each objFile In objFolder.Files
  ' http://msdn.microsoft.com/en-us/library/9fd71ty9(v=vs.84).aspx  
  ' http://msdn.microsoft.com/en-us/library/x0fxha2a(v=vs.84).aspx  
  If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Then  
    ' http://msdn.microsoft.com/en-us/library/office/ff194819(v=office.15).aspx  
    Set objWB = objExcelApp.Workbooks.Open(objFile.Path, 0, True)
    ' http://msdn.microsoft.com/en-us/library/office/ff838238(v=office.15).aspx  
    strRead = objWB.Worksheets(1).Range(strRange)
    ' http://msdn.microsoft.com/en-us/library/0764e5w5(v=vs.84).aspx  
    ' http://msdn.microsoft.com/en-us/library/238kz954(v=vs.84).aspx  
    arrRead = Split(Replace(strRead, " / ", "$"), "$")  
    ' http://msdn.microsoft.com/en-us/library/office/ff194567(v=office.15).aspx  
    ' http://msdn.microsoft.com/en-us/library/office/ff820899(v=office.15).aspx  
    objThisWS.Cells(i, 1) = objWB.Name
    ' http://msdn.microsoft.com/en-us/library/xdxy3zda(v=vs.84).aspx  
    If IsArray(arrRead) Then
      ' http://msdn.microsoft.com/en-us/library/sa3hh43e(v=vs.84).aspx  
      ' http://msdn.microsoft.com/en-us/library/fhx59d0t(v=vs.84).aspx  
      For j = 0 To UBound(arrRead)
        objThisWS.Cells(i, j + 2) = arrRead(j)
      Next
    End If
    ' http://msdn.microsoft.com/en-us/library/office/ff838613(v=office.15).aspx  
    objWB.Close False
    i = i + 1
  End If
Next

' http://msdn.microsoft.com/en-us/library/office/ff841185(v=office.15).aspx  
objThisWB.SaveAs strXls
' http://msdn.microsoft.com/en-us/library/office/ff839269(v=office.15).aspx  
objExcelApp.Quit