Office: Tabellennamen mit dem Dateinamen versehen

Hallo Zusammen

Leider komme ich mal wieder nicht weiter und bin mit meinem Latein am Ende.

Ich habe eine Datei xy.xlsm aus der ich ein Makro starte, welches mir aus einem Ordner alle *.xl* Dateien öffnen soll und die einzelnen Tabellen konsolidiert in eine eue Datei. Das Problem liegt nun darin, dass die Tabellen immer gleich heissen (Umsatzliste). Das öffnen und das zusammenführen klappt, nur das Umbenennen der einzelnen Tabellen kriege ich nicht gebacken. Ich habe mein Makro mal angehängt und hoffe irgend jemand hat eine Lösung, dass der Dateiname ohne Endung als Tabellenname dargestellt werden kann.

Sub Workbook_open()
Dim Mappe As String
Dim Ziel As Workbook
Dim intTab As Integer
Const Pfad = "Z:\Artikelstamm\Volg\2010\"

Application.SheetsInNewWorkbook = 1
Set Ziel = Workbooks.Add
Mappe = Dir(Pfad & "*.xl*")
Do While Mappe <> ""
Workbooks.Open Pfad & Mappe, UpdateLinks:=0
ActiveSheet.Name = ActiveWorkbook.Name
For intTab = 1 To Workbooks(Mappe).Sheets.Count
Workbooks(Mappe).Sheets(intTab).Copy Before:=Ziel.Sheets(1)
Next intTab
Workbooks(Mappe).Close SaveChanges:=False
Mappe = Dir
Loop
End Sub



Ich hoffe irgend jemand kann mir helfen mein Problem zu lösen

Besten Dank im Voraus

Gruss Adrian75

 

Hallo Adrian75,

ich habe Deinen Code mal durchprobiert.
Ich könnte mir vorstellen, dass es für Deine Anwendung sinnvoll sein könnte, wenn die Blätter der Mappen in Reihenfolge nacheinander einkopiert wären.

Und ich könnte mir vorstellen, dass es für Dich sinnvoll sein könnte, wenn die Blätter mit Dateinamen und dem jeweiligen Blattnamen benannt werden.

Wenn das alles so zutrifft, könnte der folgende Code was für Dich sein:

Code:

Option Explicit

Sub Workbook_open()

Dim Mappe As String
Dim Blattname As String
Dim Ziel As Workbook
Dim intTab As Integer
Const Pfad = "Z:\Artikelstamm\Volg\2010\"

Application.SheetsInNewWorkbook = 1
Set Ziel = Workbooks.Add
Mappe = Dir(Pfad & "*.xl*")

Do While Mappe <> ""
    Workbooks.Open Pfad & Mappe, UpdateLinks:=0
    Blattname = Split(ActiveWorkbook.Name, ".")(LBound(Split(ActiveWorkbook.Name, ".")))
    For intTab = 1 To Workbooks(Mappe).Sheets.Count
        Workbooks(Mappe).Sheets(intTab).Name = Blattname & " " & Workbooks(Mappe).Sheets(intTab).Name
        Workbooks(Mappe).Sheets(intTab).Copy after:=Ziel.Sheets(Ziel.Sheets.Count)
    Next intTab
    Workbooks(Mappe).Close SaveChanges:=False
    Mappe = Dir
Loop

End Sub

Falls ich daneben liege, kannst Du vermutlich den Code so anpassen wie Du ihn brauchst, ansonsten frage nochmal, dann helfe ich Dir.

Ich hoffe geholfen zu haben.


P.S.:
Wofür ist eigentlich "Application.SheetsInNewWorkbook = 1" gut?
Bei mir läuft der Code auch ohne diese Zeile sauber durch.

 

Hallo fette Elfe und natürlich auch allen anderen ein freundliches Hallo

Besten Dank für Deine Hilfe.. Du hast das Problem erkannt und mir schon sehr geholfen..

Die Namen der Tabellen habe ich noch ein Bisschen angepasst, aber nicht wirklich gravierend. Vielleicht kannst Du mir trotzdem noch weiter helfen.

Jetzt ist es eigentlich nur noch Detailarbeit. Ist es möglich die Tabellen nicht in eine neue Mappe zu kopieren sondern direkt in die Mappe aus der das Makro gestartet wird und die Tabelle1 nicht dargestellt wird?

Schön wäre auch noch, wenn die Tabellen dieselbe Reihenfolge hätten wie im Windows Explorer dargestellt wird. Hast Du auch dazu noch eine Idee?

Aber wirklich nochmal besten Dank für Deine Unterstützung. Mein Projekt ist noch nicht ganz fertig damit, versuche aber selber weiter zu kommen. Aber falls ich es nicht schaffen sollte, würde ich mich gerne hier wieder melden.

In diesem Sinne wünsche ich noch einen schönen Tag

Gruss Adrian75

P.s.: Sollte meine Arbeit dann irgendwann mal abgeschlossen sein, werde ich den ganzen Code hier nochmal posten, damit auch andere die ein ähnliches Problem eine Lösung finden.

 

Hallo Adrian75,

Welche Namen genau hast Du denn wie angepasst, dass es mich hindern sollte Dir weiter zu helfen?
;O)

Habe ich eingebaut (s.u.), und zusätzlich zur Sicherheit auch noch die Abfrage, ob die zu öffnende Mappe die Mappe mit dem Makro ist, denn dann würde es Fehlermeldungen geben.

Ich verstehe nicht wirklich worauf Du Dich hier jetzt beziehst.
Erkläre bitte mal was wo nicht dargestellt werden soll.

Habe ich, aber dafür müsste ich den Aufbau der Dateinamen kennen.
Haben die Namen immer den gleichen Stamm und sind sie durchnummeriert, oder mit Datum versehen?
Wie unterscheiden sie sich und was ist eventuell immer gleich?
Am besten wäre eine handvoll reale Dateinamen als Beispiel.
Denn:
Die Sortierung im Explorer ist nur die Vorgabe, wie Dir die Dateien angezeigt werden sollen.
Das hat nichts damit zu tuen wie Windows die Dateien intern sortiert/ausliest.
Und Excel arbeitet halt die Dateien der Reihe nach ab, sprich in der Reihenfolge wie Windows sie sortiert. Egal wie Du sie Dir anzeigen lässt.

Das bedeutet in der Praxis:
"Mappe10" kommt hinter "Mappe1" und nicht hinter "Mappe9", weil die Nummerierung mit "1" beginnt.

Vermeiden kann man dies, indem man es bereits bei der Namensvergabe berücksichtigt:
Mappe01
Mappe02
...
...
Mappe10

oder
Mappe 2012-02-01
Mappe 2012-02-02

Ich hoffe Du hast verstanden worauf ich hinaus will.

Eine andere Möglichkeit wäre, die Tabellenblätter zu sortieren sobald alle Dateien ausgelesen wurden.
Dafür müsste man aber einen Code schreiben, denn die "normale" Sortierung scheint ja nicht zu greifen.
Und für diesen Code müsste man ganz genau wissen wie die Dateinamen, und dadurch die Blattnamen aufgebaut sind.
Dies halte ich aber für die schlechtere Variante.
Ordentliche Dateinamen ziehe ich persönlich immer vor.


Im Zweifelsfall wäre eine Beispieldatei langsam angebracht, damit man mal sehen kann, was genau Du möchtest.
Darin sollte natürlich der Code sein.



Und hier noch meine bisherigen Änderungen:

Code:

Option Explicit

Sub Workbook_open()

Dim Mappe As String
Dim Blattname As String
Dim intTab As Integer
Const Pfad = "Z:\Artikelstamm\Volg\2010\"

Mappe = Dir(Pfad & "*.xl*")

Do While Mappe <> ""
    If Not Mappe = ThisWorkbook.Name Then
        Workbooks.Open Pfad & Mappe, UpdateLinks:=0
        Blattname = Split(ActiveWorkbook.Name, ".")(LBound(Split(ActiveWorkbook.Name, ".")))
        For intTab = 1 To Workbooks(Mappe).Sheets.Count
            Workbooks(Mappe).Sheets(intTab).Name = Blattname & " " & Workbooks(Mappe).Sheets(intTab).Name
            Workbooks(Mappe).Sheets(intTab).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next intTab
        Workbooks(Mappe).Close SaveChanges:=False
    End If
    Mappe = Dir
Loop

End Sub

 

Hallo fetteElfe Besten Dank nochmal für Deine Bemühungen


Ich habe mein Problem mal noch an einen Kollegen weiter eskaliert und da auch noch neue Ansätze erhalten, wie man ein solches Problem auch noch lösen kann.

Zuerst meinte er, dass die Zieldatei einen neuen Namen erhalten soll, damit man das Makro als solches isolieren kann und weiter mit "normalen" Excel Tabellen ohne Makro weiter arbeiten kann, was ich eigentlich nachvollziehen kann. Also erstelle ich eine neue Datei.

Beim Erstellen einer neuen Datei wird ja immer eine Tabelle mit dem Namen "Tabelle1" eingefügt, die ich aber eben gerne gelöscht hätte.

Die Dateinamen sind so aufgebaut, dass sich der Name aus Monat-Jahr.xls oder Monat-Jahr.xlsx zusammensetzt. Jetzt muss der Tabellenname Monat-Jahr sein, also ohne Endung.

Code:

Sub Workbook_open()
    Dim FSO
    Dim Datei
    Dim Ordner
    Dim Col As New Collection
    Dim Element
    Dim app As Excel.Application
    Dim fileDialog As fileDialog
    Dim AusgabeDatei As String
    
    Set fileDialog = Excel.Application.fileDialog(msoFileDialogFolderPicker) 'FileDialog Klasse generieren
    fileDialog.AllowMultiSelect = False 'Nur ein Ordner darf auf einmal ausgewählt werden
    fileDialog.ButtonName = "OK" 'Text des OK-Buttons :)
    fileDialog.InitialFileName = Me.Path + "\" 'Pfad, der beim öffnen Standardmässig angezeigt wird (momentan der gleiche Pfad, in dem sich diese Datei befindet
    fileDialog.Title = "Bitte wählen sie den Ordner aus, in dem sich alle Dateien zum zusammenfassen befinden." 'Titel des Dialogs
    If fileDialog.Show = True Then 'Wenn ein Ordner vom Benutzer ausgewählt wurde
       Set FSO = CreateObject("Scripting.Filesystemobject") 'Das FileSystemObject erstellen, welches Notwendig ist, um auf das Dateisystem zuzugreiffen
       Set Ordner = FSO.GetFolder(fileDialog.SelectedItems(1)) 'Pfad anpassen
       For Each Datei In Ordner.Files 'Schleife über alle Dateien im Ordner laufen lassen
           Select Case LCase(FSO.GetExtensionName(Datei)) 'Extension auslesen
               Case "xls", "xlsx" 'Nur xls und xlsx Dateien miteinbeziehen
                   Col.Add Datei 'Alle Excel-Dateien in eine Collection. Die anderen ignorieren.
           End Select
       Next
       If Col.Count > 0 Then 'Falls Dateien gefunden wurden, Die zu erstellende Excel-Datei erstellen und aufrufen
       Workbooks.Add 'Eine neue Excel-Datei erstellen (Die Ausgabedatei)
       AusgabeDatei = InputBox("Dateinamen für die zu erstellende Datei eingeben:") + ".xlsx" ' Den User nach dem Namen der Ausgabedatei fragen...
       ActiveWorkbook.SaveAs fileDialog.SelectedItems(1) + "\" + AusgabeDatei ' Und das Ding gleich mal unter diesem Namen speichern
           For x = Col.Count To 1 Step -1
               Workbooks.Open (fileDialog.SelectedItems(1) + "\" + Col.Item(x).Name) 'Die vorher gefundenen Dateien jeweils öffnen...
               Workbooks(Col.Item(x).Name).Sheets(1).Copy Before:=Workbooks(AusgabeDatei).Sheets(1) 'Das erste Blatt einer jeden gefundenen Datei in die aktuelle Excel-Datei kopieren...
               Workbooks(AusgabeDatei).Sheets(1).Name = Left(Col.Item(x).Name, InStrRev(Col.Item(x).Name, ".") - 1) 'Den Blatt-Namen richtig stellen...
               Range(Cells(1, 1), Cells(1, 2)).MergeCells = True
               Workbooks(AusgabeDatei).Sheets(1).Columns("A").NumberFormat = "0"
               Workbooks(AusgabeDatei).Sheets(1).Columns("C").NumberFormat = "0"
               Workbooks(AusgabeDatei).Sheets(1).Columns("D").NumberFormat = "0"
               Workbooks(AusgabeDatei).Sheets(1).Columns("A:H").EntireColumn.AutoFit
               Workbooks(Col.Item(x).Name).Close SaveChanges:=False 'Und die aktuelle Excel-Datei wieder schliessen
           Next
           'Das erste, leere Blatt löschen (befindet sich nun an letzter Stelle)
           Application.DisplayAlerts = False
           Dim differenz As Integer
           differenz = Workbooks(AusgabeDatei).Sheets.Count - Col.Count
           For x = 1 To differenz
            Workbooks(AusgabeDatei).Sheets(Workbooks(AusgabeDatei).Sheets.Count).Delete
           Next
           Application.DisplayAlerts = True
       Else
           'Es gibt keine Excel-Dateien in diesem Ordner, User benachrichtigen...
           MsgBox "Es existieren keine Excel-Dateien in dem von Ihnen gewählten Ordner, bitte einen gültigen Ordner wählen!", vbCritical, "Keine Excel-Dateien gefunden!"
           Me.Close False 'Datei schliessen...
           Exit Sub 'und beenden
       End If
       'Und fertig, alles geklappt! :) Die Datei gleich in einem Format ohne Makros zum weiterbearbeiten speichern....
       Workbooks(AusgabeDatei).Save
       Me.Close True
    Else
        'Abbrechen gedrückt, hier mache ich extra nichts, damit die Datei geöffnet bleibt und man dieses Makro sehen und anpassen kann ;)
    End If
End Sub
 

Ich hoffe meine Ausführungen zusammen mit dem Code sind einigermassen verständlich. Falls nicht einfach nochmal nachfragen.

Jetzt sind alle Tabellen an einem Ort, jetzt müssen "nur" noch die Formeln in die richtigen Felder eingetragen werden und das gesamte Projekt kann abgeschlossen werden.

Besten Dank an alle die sich bis jetzt hier beteiligt und sich den Kopf zerbrochen haben.

Gruss Adrian

 

Hallo Adrian,

ich bin mir nicht sicher ob Du noch eine offene Frage hast.
Anscheinend hast Du ja jetzt alles zu Deiner Zufriedenheit gelöst, oder?

Deinen Code habe ich mal durchlaufen lassen, scheint ja alles zu machen was er soll.
Freut mich das Du es hinbekommen hast.

Falls doch noch Fragen auftauchen sollten, einfach nochmal melden.