Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Zusammenfügen mehrere XLSM Files zu einer Datei | Herbers Excel-Forum


Betrifft: Zusammenfügen mehrere XLSM Files zu einer Datei von: Matz
Geschrieben am: 24.01.2012 16:31:43

Hallo zusammen

Ich habe folgendes Problem bei dem ich nicht weiter komme und auch leider per google keine Lösung gefunden habe.
Vorweg. Ich habe immer noch keine Ahnung von VBA.

Ich habe 130 XLMS Dateien, mit jeweils 7 Tabellenblättern.
Alle Files liegen in einem Ordner und sind jeweils unterschiedlich benannt.
Der Aufbau der 130 Files ist absolut identisch.
Die Spaltenanzahl ist pro Tabellenblatt unterschiedlich, aber für alle 130 Tabellen jeweils gleich.
Die Zeilenanzahl ist pro Tabellenblatt unterschiedlich und auch für alle 130 Tabellen unterschiedlich.
Es kann sein dass einzelne Tabellenblätter nur eine Überschrift haben, aber keinen Inhalt.
Es kann sein dass durch merkwürdige Formatierung z.B. nur 20 Zeilen auf einem Tabellenblatt gefüllt sind, aber dennoch 200 Zeilen mit Linien formatiert sind.

Was ich nun möchte.

1. Zusammenfügen aller 130 XLMS Files zu einer Datei
2. Tabellenstruktur (7 Tabellenblätter) soll beibehalten bleiben.
3. Hinzufügen einer Spalte A (A existiert schon, müsste also nach rechts verschoben werden) mit dem Dateinamen der kopierten Datei um die Inhalte später noch den 130 Ursprungstabellen zuordnen zu können.
4. Wenn Ursprungszellen farblich markiert oder der Text farblich unterlegt war, soll das auch im zusammengeführten Dokument der Fall sein. Linien und Rahmen hingegen müssen (können aber) nicht übernommen werden.

Kann mir jemand von Euch helfen?

Viele Grüsse
Matz

  

Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer Datei von: Dirk
Geschrieben am: 24.01.2012 19:39:37

Hallo Matz

na da hast du ja was vor

du bist dir aber im klaren wie groß und unhandlich eine solche Datei wir?

hast du noch andere Dateien außer die xlms in dem Ordner?

Gruß
Dirk


  

Betrifft: Zusammenfügen mehrere XLSM Files zu einer von: Matz
Geschrieben am: 24.01.2012 20:30:27

Hallo Dirk
danke fuer Dein Feedback.

Ja, ich bn mir klar wie gross die file wird. In ca. 80 % besteht ein tabellenblatt aus max 30 zeilen. Viele weniger, weniger mehr, ganz wenige viel mehr.
Das ist auch genau der Grund warum ich daraus eine file machen will.

Dann haette ich nur noch eine file mit 7 tabellenblaettern mit jeweils max 20000 Zeilen (sehr sehr sehr pessimistisch geschaetzt.

Kannst Du helfen?

viele gruesse
matz


  

Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
Geschrieben am: 24.01.2012 20:39:00

Also du möchtest die Daten der einzelnen Dateien untereinander bringen?

und dann einen nach rechts verrückt und in "A" den jeweiligen Dateinamen wenn ich dich recht verstanden habe?

Gruß
Dirk


  

Betrifft: Zusammenfügen mehrere XLSM Files zu einer von: Matz
Geschrieben am: 24.01.2012 21:52:43

Hallo Dirk

ganz genau.
Ich möchte letztlich 130 Dateien eine neue machen.

Der Aufbau (7 Tabellenblätter pro Datei - die haben in allen Dateien die gleiche Bezeichnung die sich innerhalb einer Datei natürlich unterscheided)

Das mit der Spalte A hast Du auch genau richtig verstanden.

Viele Gruesse



Matz


  

Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
Geschrieben am: 24.01.2012 22:05:46

ok hier erstmal ein teilcode

bin müde und komm auch erstaml nicht mehr dazu

vieleicht hat ein anderer ja lust und laune die Letzten Passagen fertig zu machen
(Morgen bin ich nicht da)

Sub import_starten()

Dim Ordner As String
Dim x As Long
ReDim strarray(1)
zeil = 2
Pfad = GivePath & "\"

Ordner = Dir(Pfad, vbDirectory)
If Ordner = "" Then
    MsgBox "kein Ordner oder Dateien!"
    Exit Sub
End If

Do While Ordner <> ""
    If Ordner <> "." And Ordner <> ".." Then
        If (GetAttr(Pfad & Ordner) And vbDirectory) <> vbDirectory Then
            strarray(x) = Ordner
            x = x + 1
            ReDim Preserve strarray(x)
        End If
    End If
    Ordner = Dir
Loop

For i = 0 To UBound(strarray) - 1
import (Pfad & strarray(i))
Next
End Sub
Sub import(str As String)
Dim wb, wbn As Workbook
Dim ZelleLetzte, lz2 As Range

Set wb = ThisWorkbook
  
  For Each Worksheet In wbn.Worksheets
         
       With wbn.Sheets(Worksheet.Name)
      With .Range("a2:AB2000")
        Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
              lookat:=xlWhole, searchdirection:=xlPrevious)
      End With
       
      If ZelleLetzte Is Nothing Then
        MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & Worksheet.Name)
      Else
     
        .Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _
            Destination:=wb.Sheets(Worksheet.Name).Range("B1")          'hier muss noch was  _
passieren
            'abfrage bis wo sind die Zellen belegt in zieldatei
            'so wir überschrieben
           'Spalte a wbn.name & "_" & worksheet.name
      End If
    End With
    
    
 
  Next
  wbn.Close
  Set wb = Nothing
  Set wbn = Nothing
End Sub

Public Function GivePath() As String
Dim fDialog As FileDialog
Dim result As Integer
'Dateidialog für Auswahl
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
On Error Resume Next
With fDialog
.AllowMultiSelect = False
.Title = "Ordner wählen"
.Filters.Delete
.InitialFileName = "c:\" 'Wichtig = "\"
result = .Show
If (result <> 0) Then
GivePath = Trim(.SelectedItems.Item(1))
Else
GivePath = ""
End If
End With
End Function




  

Betrifft: kann jemand weiter helfen. von: Matz
Geschrieben am: 24.01.2012 22:23:29

Hallo Dirk
vielen Dank schonmal.

Das doch schon mal superlieb gewesen. Danke!!

Kannst Du noch kurz erklären, was der Code bis jetzt macht?

Vielen Dank und viele Grüsse
Matz


  

Betrifft: AW: kann jemand weiter helfen. von: Josef Ehrensberger
Geschrieben am: 24.01.2012 23:50:25


Hallo Matz,

wie sehen die Dateien den aus? (Tabellenaufbau)




« Gruß Sepp »



  

Betrifft: AW: kann jemand weiter helfen. von: Matz
Geschrieben am: 25.01.2012 08:56:52

Hallo Sepp

Die Dateien haben alle den gleichen Aufbau.

Jeweils 7 Tabellenblätter

  • Tabellenblatt 1 hat 2 Spalten ( A und B)

  • Tabellenblatt 2 hat 3 Spalten ( A bis C)

  • Tabellenblatt 3 hat 4 Spalten ( A bis D)

  • Tabellenbaltt 4 hat 3 Spalten ( A bis C)

  • Tabellenblatt 5 hat 3 Spalten ( A bis C)

  • Tabellenblatt 6 hat 20 Spalten ( A bis T)

  • Tabellenblatt 7 hat 6 Spalten (A - F)


  • Die Zeilenanzahl kann variieren. Massgeblich ist aber immer, ob Spalte A gefüllt ist oder nicht.

    Ist das die Info die Du benötigts?

    Viele Grüsse
    Matz


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
    Geschrieben am: 25.01.2012 07:53:23

    hab gerade 2 min zeit gehabt und kurz weiter getippt.

    ich glaub das funktioniert.

    hab hier aberer gerade kein Office 2007 zu Hand.

    musst du also testen
    nimm dafür am besten einen Ordner in dem nicht so viele Dateien sind.

    Sub import_starten()
      
      Dim Ordner As String
      Dim x As Long
      ReDim strarray(1)
      zeil = 2
      Pfad = GivePath & "\"
      
      Ordner = Dir(Pfad, vbDirectory)
      If Ordner = "" Then
          MsgBox "kein Ordner oder Dateien!"
          Exit Sub
      End If
      
      Do While Ordner <> ""
          If Ordner <> "." And Ordner <> ".." Then
              If (GetAttr(Pfad & Ordner) And vbDirectory) <> vbDirectory Then
                  strarray(x) = Ordner
                  x = x + 1
                  ReDim Preserve strarray(x)
              End If
          End If
          Ordner = Dir
      Loop
      
      For i = 0 To UBound(strarray) - 1
      import (Pfad & strarray(i))
      Next
      End Sub
      Sub import(str As String)
        Dim wb, wbn As Workbook
      Dim ZelleLetzte, lz2 As Range
      Dim efz As Integer
       
      Set wb = ThisWorkbook
      Set wbn = Workbooks.Open(str)
       
        For Each Worksheet In wbn.Worksheets
               
            With wbn.Sheets(Worksheet.Name)
                 With .Range("a2:AB2000")
                    Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
                    lookat:=xlWhole, searchdirection:=xlPrevious)
                End With
             
             With wb.Sheets(Worksheet.Name).Range("b2:b500")
                    Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _
                    lookat:=xlWhole, searchdirection:=xlPrevious)
            End With
                  efz = lz2.Row + 1
                 If ZelleLetzte Is Nothing Then
                        MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " &  _
    Worksheet.Name)
                    Else
                        .Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _
                        Destination:=ThisWorkbook.Sheets(Worksheet.Name).Range("B" & efz)
                        ThisWorkbook.Sheets(Worksheet.Name).Range("a" & efz) = str & "_" &  _
    Worksheet.Name
                        End If
          End With
          
          
       
        Next
        wbn.Close
        Set wb = Nothing
        Set wbn = Nothing
      End Sub
      
      Public Function GivePath() As String
      Dim fDialog As FileDialog
      Dim result As Integer
      'Dateidialog für Auswahl
      Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
      On Error Resume Next
      With fDialog
      .AllowMultiSelect = False
      .Title = "Ordner wählen"
      .Filters.Delete
      .InitialFileName = "c:\" 'Wichtig = "\"
      result = .Show
      If (result <> 0) Then
      GivePath = Trim(.SelectedItems.Item(1))
      Else
      GivePath = ""
      End If
      End With
      End Function
    
    
    Gruß
    Dirk


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Matz
    Geschrieben am: 25.01.2012 09:14:25

    Hallo Dirk

    Vielen Dank!

    Ich bekomme folgende Fehlermeldung:

    Laufzeitfehler '9': 
    Index außerhalb des gültigen Bereichs
    
    Wenn ich das debugge, wird mir folgendes angezeigt
    Sub import(str As String)
        Dim wb, wbn As Workbook
      Dim ZelleLetzte, lz2 As Range
      Dim efz As Integer
       
      Set wb = ThisWorkbook
      Set wbn = Workbooks.Open(str)
       
        For Each Worksheet In wbn.Worksheets
               
            With wbn.Sheets(Worksheet.Name)
                 With .Range("a2:AB2000")
                    Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
                    lookat:=xlWhole, searchdirection:=xlPrevious)
                End With
             
             With wb.Sheets(Worksheet.Name).Range("b2:b500")
                    Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _
                    lookat:=xlWhole, searchdirection:=xlPrevious)
            End With
                  efz = lz2.Row + 1
                 If ZelleLetzte Is Nothing Then
                        MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & _
    Worksheet.Name)
                    Else
                        .Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _
                        Destination:=ThisWorkbook.Sheets(Worksheet.Name).Range("B" & efz)
                        ThisWorkbook.Sheets(Worksheet.Name).Range("a" & efz) = str & "_" & _
    Worksheet.Name
                        End If
          End With
          
          
       
        Next
        wbn.Close
        Set wb = Nothing
        Set wbn = Nothing
      End Sub

    Mache ich etwas falsch, oder hat der Code noch einen Fehler?

    Viele Grüsse
    Matz


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
    Geschrieben am: 25.01.2012 09:50:37

    das kann ich dir gerade nicht sagen, da ich deine Dateien nicht da habe.

    Ich habe den Code so geschrieben, das in der Zieldatei (die mit dem Makro) alle Tabellenblätter mit dem gleichen namen wie aus den Ursprungsdateien vorhanden sind.

    ich konnte den gerade nur unter Office 2002 laufen lassen da lief alles

    überprüf erstmal ob alle Tabellenblätter in der Datei für die zusammenfassung vorhanden sind

    gruß
    Dirk


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Matz
    Geschrieben am: 25.01.2012 10:31:00

    Hallo Dirk

    Ich habe nun im Dokument "Zusammenfassung.xlsm" alle Tabellenblätter identisch der 130 zu kopierenden angelegt.
    Da das auch nichts geholfen hat, habe ich auch in jedem Tabellenblatt der "zusammenfassung.xlsm" die Überschriften angelegt.
    Beides hat nichts geholfen.

    Der Debugger beschwert sich weiterhin bei

    With wb.Sheets(Worksheet.Name).Range("b2:b500")
    Aber Du hast eh schon zuviel Zeit hineingesteckt. Ich werde jetzt einfach etwas rumbasteln und wenn es dann immer noch nicht funktioniert, werde ich die Arbeit halt manuell machen...

    Vielen vielen Dank!!!

    Viele Grüsse
    Matz


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
    Geschrieben am: 25.01.2012 11:17:38

    der läuft auf den Fehler beim ermittel der ersten freien zeile in dem Dazugehörigem blatt in der Zusammenfassung

     With wb.Sheets(Worksheet.Name).Range("b2:b500")
                     Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _
                     lookat:=xlWhole, searchdirection:=xlPrevious)
             End With
    
     efz = lz2.Row + 1

    Diese Passage befasst sich wirklich nur damit die erste freie Zeile zu finden.

    wenn du die weg lassen würdest, würde er immer alles überschreiben

    fals jemand anderes noch ne idee hatt, wei man die erste freie zeile anders ermitteln kann, kannst du die Passage einfach austauschen

    Gruß
    Dirk


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Matz
    Geschrieben am: 25.01.2012 11:56:36

    Hallo Dirk,
    ok einen Fehler habe ich gefunden.
    Auf den Quelldateien gibt es noch ein Ausgeblendetes (veryhidden) Tabellenblatt.
    Dies habe ich nun analog auch in meiner Zusammenfassungstabelle angelegt.

    Jetzt läuft der Code schon weiter:

    ith wb.Sheets(Worksheet.Name).Range("b2:b5000")
                    Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _
                    lookat:=xlWhole, searchdirection:=xlPrevious)
            End With
            -------->     efz = lz2.Row + 1  ---------------<  
                 If ZelleLetzte Is Nothing Then
                        MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & _
    Viele Grüsse
    Matz


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
    Geschrieben am: 25.01.2012 17:58:00

    ich hoffe das klappt mit dem Download

    https://rapidshare.com/files/2360541482/zusammen.rar

    Hier sind meine beispieldateien und die endgültige Zusammenfassung

    das Makro liegt in der Tabelle import

    ich hoffe mal das haut jetzt hin

    der hat da rumgesponnen, weil er die erste freie Zelle bei dem ersten durchlauf nicht richtig findet

    Gruß
    Dirk


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Matz
    Geschrieben am: 26.01.2012 09:30:08

    Suuuuuper!

    Vielen vielen Dank Dirk

    Das klappt jetzt prima!

    Gruss
    Matz


      

    Betrifft: AW: Zusammenfügen mehrere XLSM Files zu einer von: Dirk
    Geschrieben am: 26.01.2012 16:54:59

    https://rapidshare.com/files/1284039024/Zusammen.rar

    etwas schöner


    Beiträge aus den Excel-Beispielen zum Thema "Zusammenfügen mehrere XLSM Files zu einer Datei"