Microsoft Excel

Herbers Excel/VBA-Archiv

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

Zusammenführung von Dateien

Betrifft: Zusammenführung von Dateien von: Steffen
Geschrieben am: 14.08.2014 16:19:38

Hallo Zusammen,

ich hab jetzt schon stunden bei Google nach einer lösung für mein Problem gesucht jedoch nicht das richtige gefunden :-(.

Ich habe mehrere Excel Dateien mit jeweils einer Tabelle in einem Ordner. Ich bräuchte nun ein Makro, welches diese Excel Dateien zu einer macht. Sprich ich habe eine Datei A mit Tabelle A welche in eine neue Datei in Tabelle 1 eingefügt werden soll, Datei B mit Tabelle B soll in die neue Datei in Tabelle 2 eingefügt werden, Datei C mit Tabelle C soll in die neue Datei in Tabelle 3 eingefügt werden und so weiter. Die Tabellen in den einzelnen Excel Dateien sind immer unterschiedlich lang und es sind auch immer unterschiedlich viele Excel Dateien.

Es sollten alle Exceldateien aus dem Order in die neue Datei eingefügt werden, wobei der Name der Tabellen/Mappen in der neuen Datei den Namen der Exceldateien entspricht. Den Pfad bzw. die Dateien, welche in die neue Datei eingefügt werden sollen, soll Excel bei Start des Makros abfragen.

Ich hab selber schon ein wenig rumprobiert, komme da aber zu keiner passenden Lösung, hoffe Ihr könnt mir helfen, ein Meeeeeeeeeeeggggggggga Dankeschön schonmal vorab. :-)

LG Steffen

  

Betrifft: AW: Zusammenführung von Dateien von: JoWE
Geschrieben am: 14.08.2014 17:44:23

Hallo Steffen,

schreibe die Pfade , die Arbeitsmappen(Namen) und die zu kopierenden Tabellenblattnamen in die Spalten A, B und C untereinander. Für das Beispielmakro beginnst Du damit in Zeile 2. Die Pfadnamen im Makro musst Du noch anpassen:

Sub daten_aus_wbs()
    Dim myWb As Workbook
    Dim mySh As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim myTab As String
    Dim zeile As Long
    Set myWb = ThisWorkbook
    Set mySh = myWb.Sheets("Dateien")
    myPath = mySh.Range("A2").Value
    myFile = mySh.Range("B2").Value
    myTab = mySh.Range("C2").Value
    With mySh
        For zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Workbooks.Open fileName:=myPath & "/" & myFile
            Sheets(myTab).Copy after:=Workbooks(myWb.Name).Sheets(mySh.Name)
            Windows(myFile).Close savechanges:=False
            ActiveSheet.Name = myTab
        Next
    End With
End Sub
Gruß
Jochen


  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 15.08.2014 10:10:58

Guten Morgen Jochen,

vielen Dank schonmal für deine Mühe, jedoch ist es nicht ganz was ich suche :-(
Ich versuche es nochmal genauer zu schildern:

Als Beispiel:
Ich habe einen Ordner mit 3 Exceldateien/Workbooks, (DateiA, DateiB,DateiC in denen jeweils in Sheet1 Daten enthalten sind. Nun soll aus diesen 3 Exceldateien/Workbooks jeweils das Sheet1 Kopiert und in eine neue Exceldatei/Workbook eingefügt werden, jedoch nicht alle Daten aus den 3 Exceldateien/Workbooks in Sheet1 sondern für jede der 3 Dateien/Workbooks soll ein eigenenes Sheet in der neuen Datei/Workbook angelegt werden, sodass ich am Ende eine Exceldatei mit 3 Sheets habe in denen die Daten enthalten sind.

Also:

1. Excel soll nach dem Pfad Fragen, wo die Exceldateien/Workbooks liegen, dass hab ich schon mit

Application.GetOpenFilename("Excel Files(*.xlsx),*.xlsm", hinbekommen.

2. Jeweils das erste Sheet aus den ausgewählten Dateien/Workbooks soll kopiert werden (Das erste Sheet aller ausgewählert Workbooks)

3. Jetzt soll eine neue Datei/Workbook geöffnet werden. Für jede ausgewählte Datei/Workbook soll nun ein eigendes Sheet in der neuen Datei/Workbook erstellt werden. wo die Daten eingefügt werden.

Das Problem ist, dass ich immer unterschiedlich viele ExcelDateien/Workbooks auswählen muss und die Tabellen/Daten in den Sheets sind immer unterschiedlich lang, jedoch immer gleich breit.

Danke,Danke,Danke
Steffen ;-)



  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 17.08.2014 22:31:38

Keiner eine Idee wie das funktionieren könnte? :-(


  

Betrifft: AW: Zusammenführung von Dateien von: fcs
Geschrieben am: 18.08.2014 10:05:03

Hallo Steffen,

eine intensive Suche in der RECHERCHE hätte sicher was brauchbares zu Tage gefördert.

Gruß
Franz

Sub Tabelle1_Holen_aus_Dateien()
  '1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe zusammenkopieren
  Dim wkbZiel As Workbook, wksZiel As Worksheet
  Dim varVerzeichnis As Variant
  Dim wkbQuelle As Workbook, wksQuelle As Worksheet
  Dim strDatei As String, intK As Integer
  On Error GoTo Fehler
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die zusammengefasst werden  _
sollen"
    If .Show = -1 Then
      varVerzeichnis = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  strDatei = Dir(varVerzeichnis & "\*.xls*")
  If strDatei = "" Then
    MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
    Exit Sub
  End If
  
  'Makrobremsen lösen
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
  End With
  Do Until strDatei = ""
    'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
    If LCase(strDatei) <> LCase(ThisWorkbook.Name) Then
      intK = intK + 1
      Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
      Set wkbQuelle = Application.Workbooks.Open(Filename:=varVerzeichnis & "\" & strDatei, _
          ReadOnly:=True, UpdateLinks:=False)
      Set wksQuelle = wkbQuelle.Worksheets(1)
      wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn Formeln vorhanden sind
      'wenn keine Formeln kopiert werden sollen
      With wksQuelle.UsedRange
        .Value = .Value
      End With
      'Blatt in neue Mappe kopieren
      If wkbZiel Is Nothing Then
        wksQuelle.Copy
        Set wkbZiel = ActiveWorkbook
      Else
        wksQuelle.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
      End If
      'kopiertes Blatt umbenennen
      Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
      wksZiel.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
      'Quelldatei ohne speichern wieder schließen
      wkbQuelle.Close savechanges:=False
      Set wksQuelle = Nothing
      Set wkbQuelle = Nothing
    End If
    strDatei = Dir
  Loop
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
  End With
  MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
        If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
        With Application
          .ScreenUpdating = True
          .EnableEvents = True
          .Calculation = xlCalculationAutomatic
          .StatusBar = False
        End With
    End Select
  End With
Beenden:
End Sub




  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 18.08.2014 14:34:13

Hallo Franz,

wie gesagt meine VBA Kentnisse sind "bescheiden" ich verstehe leider erst einen kleinen Teil dessen, was die einzelnen Commends wirklich ausführen und wie das ganze dann im Zusammenspiel funktioniert. Wenn ich das alles wüsste, hätte ich mit sicherheit was gefunden.


Riesen Dankeschön schonmal für deinen Code :-)

Ich hoffe du hilfst mir nochmal, wie müsste man den Code verändern, damit aus der zu Kopierenden Tabelle1 immer nur ein bestimmter Bereich sagen wir als Beispiel mal A18:B118 Kopiert wird.
Ich habe jetzt schon ein wenig rum probiert, hoffe das ich an der richtigen stelle Probiert habe.

Set wksQuelle = wkbQuelle.Worksheets(1).Range("A18:B116").Selection

oder

Set wksQuelle = wkbQuelle.Worksheets(1).Sheet.Range"A18:B116")

klappt leider nicht :(


  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 19.08.2014 09:15:01

Guten Morgen,

habe nun Gestern noch probiert und gegoogelt und herausgefunden, dass mit

With wksQuelle.UsedRange
.Value = .Value
End With

der gesamte Bereich angesprochen wird, welcher genutzt wird.

Wenn ich es jetzt auf:

With wksQuelle.Range("A23:Z120")
.Value = .Value
End With

ändere, läuft es allerdings auf einen Fehler :-/ Ich hab dann noch weiter rumprobiert aber egal wie ich es drehe und wende komme ich immer wieder auf einen Fehler...


  

Betrifft: AW: Zusammenführung von Dateien von: fcs
Geschrieben am: 19.08.2014 10:48:02

Hallo Steffen,

im Moment wird ja immer das komplette Tabellenblatt nach der Umwandlung von Formeln in Werte von der Quelldatei in die Zieldatei kopiert. Das hat den Vorteil, dass man sich nicht um Formatierungen und Seitenlayout des Tabellenblatts kümmern. Probleme gibt es "nur", wenn die Quelldateien alte (2003 und älter) und neue (2007 und jünger) Dateiformate beinhalten.

Grundsätzlich gäbe es jetzt 2 Varianten:

A) Nach dem Kopieren des Blattes in die Zieldatei werden die nicht benötigten Spalten und Zeilen gelöscht.

B) Aus der Tabelle der 1. Quelldatei wird eine Mustertabelle generiert.
Bei den weiteren Quelldateien wird dann jeweils die Mustertabelle kopiert und der gewünschte Quelldatenbereich hineinkopiert.

Nachfolgended findest du das ursprüngliche Makro angepasst für beide Varianten.
Hier musst du die Zeilen-/Spaltenbereiche und den zu kopierenden Bereich anpassen.

Gruß
Franz

'Variante A
Sub Tabelle1_Holen_aus_Dateien_A()
  '1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe zusammenkopieren
  'und nicht gewünschte Daten löschen
  Dim wkbZiel As Workbook, wksZiel As Worksheet
  Dim varVerzeichnis As Variant
  Dim wkbQuelle As Workbook, wksQuelle As Worksheet
  Dim strDatei As String, intK As Integer
  Dim Zeile_L As Long, Spalte_L As Long
  On Error GoTo Fehler
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
      & "zusammengefasst werden sollen"
    If .Show = -1 Then
      varVerzeichnis = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  strDatei = Dir(varVerzeichnis & "\*.xls*")
  If strDatei = "" Then
    MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
    Exit Sub
  End If
  
  'Makrobremsen lösen
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
  End With
  Do Until strDatei = ""
    'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
    If LCase(strDatei) <> LCase(ThisWorkbook.Name) Then
      intK = intK + 1
      Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
      Set wkbQuelle = Application.Workbooks.Open( _
          Filename:=varVerzeichnis & "\" & strDatei, _
          ReadOnly:=True, UpdateLinks:=False)
      Set wksQuelle = wkbQuelle.Worksheets(1)
      wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
      'wenn keine Formeln kopiert werden sollen
      With wksQuelle.UsedRange
        .Value = .Value
      End With
      'Blatt in neue Mappe kopieren
      If wkbZiel Is Nothing Then
        wksQuelle.Copy
        Set wkbZiel = ActiveWorkbook
      Else
        wksQuelle.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
      End If
      'kopiertes Blatt umbenennen
      Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
      With wksZiel
        .Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
        Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
        Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
        'Überzälige Zeilen löschen - von unten her
          '- Zeilen am Ende der Liste
        If Zeile_L > 120 Then
          .Range(.Rows(121), .Rows(Zeile_L)).Delete
        End If
          '- Zeilen am Anfang der Liste
        .Range(.Rows(1), .Rows(22)).Delete
        'Überzälige Spalten löschen - rechts kommend
          '- Spalten rechts in Liste
        If Spalte_L > 26 Then
          .Range(.Columns(27), .Columns(Spalte_L)).Delete
        End If
          '- Spalten links in Liste
        'nicht zutreffend
      End With
      'Quelldatei ohne speichern wieder schließen
      wkbQuelle.Close savechanges:=False
      Set wksQuelle = Nothing
      Set wkbQuelle = Nothing
    End If
    'nächste Datei suchen
    strDatei = Dir
  Loop
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
  End With
  MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
        If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
        With Application
          .ScreenUpdating = True
          .EnableEvents = True
          .Calculation = xlCalculationAutomatic
          .StatusBar = False
        End With
    End Select
  End With
Beenden:
End Sub


'Variante B
Sub Tabelle1_Holen_aus_Dateien_B()
  'Daten aus 1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe  _
zusammenkopieren
  Dim wkbZiel As Workbook, wksZiel As Worksheet
  Dim varVerzeichnis As Variant
  Dim wkbQuelle As Workbook, wksQuelle As Worksheet, wksMuster As Worksheet
  Dim strDatei As String, intK As Integer
  Dim Zeile_L As Long, Spalte_L As Long
  On Error GoTo Fehler
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
      & "zusammengefasst werden sollen"
    If .Show = -1 Then
      varVerzeichnis = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  strDatei = Dir(varVerzeichnis & "\*.xls*")
  If strDatei = "" Then
    MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
    Exit Sub
  End If
  
  'Makrobremsen lösen
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
  End With
  Do Until strDatei = ""
    'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
    If LCase(strDatei) <> LCase(ThisWorkbook.Name) Then
      intK = intK + 1
      Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
      Set wkbQuelle = Application.Workbooks.Open( _
          Filename:=varVerzeichnis & "\" & strDatei, _
          ReadOnly:=True, UpdateLinks:=False)
      Set wksQuelle = wkbQuelle.Worksheets(1)
      wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
      'wenn keine Formeln kopiert werden sollen
      With wksQuelle.UsedRange
        .Value = .Value
      End With
      'Blatt in neue Mappe kopieren
      If wkbZiel Is Nothing Then
        wksQuelle.Copy
        Set wkbZiel = ActiveWorkbook
        Set wksMuster = wkbZiel.Worksheets(1)
        With wksMuster
          .Name = "Musterblatt"
          'Musterblatt aufbereiten
          'Inhalte im Zieldatenbereich löschen
          .Range("A23:Z120").ClearContents
          'letzte Zeile und Spalte ermitteln
          Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
          Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
          'Überzälige Zeilen löschen - von unten her
            '- Zeilen am Ende der Liste
          If Zeile_L > 120 Then
            .Range(.Rows(121), .Rows(Zeile_L)).Delete
          End If
            '- Zeilen am Anfang der Liste
          .Range(.Rows(1), .Rows(22)).Delete
          'Überzälige Spalten löschen - rechts kommend
            '- Spalten rechts in Liste
          If Spalte_L > 26 Then
            .Range(.Columns(27), .Columns(Spalte_L)).Delete
          End If
            '- Spalten links in Liste
          'nicht zutreffend
          Application.ScreenUpdating = True
          .Range("A1").Select
          Application.ScreenUpdating = False
        End With
      End If
      'Musterblatt kopieren
      wksMuster.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
      'kopiertes Blatt umbenennen
      Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
      With wksZiel
        .Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
        wksQuelle.Range("A23:Z120").Copy Destination:=.Cells(1, 1)
      End With
      'Quelldatei ohne speichern wieder schließen
      wkbQuelle.Close savechanges:=False
      Set wksQuelle = Nothing
      Set wkbQuelle = Nothing
    End If
    'nächste Datei suchen
    strDatei = Dir
  Loop
  'Musterblatt wieder löschen
  Application.DisplayAlerts = False
  wksMuster.Delete
  Application.DisplayAlerts = True
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
  End With
  MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
        If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
        With Application
          .ScreenUpdating = True
          .EnableEvents = True
          .Calculation = xlCalculationAutomatic
          .StatusBar = False
        End With
    End Select
  End With
Beenden:
End Sub



  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 19.08.2014 14:01:50

Hallo Frank,

vielen Dank nochmal für deine Bemühungen, es funktioniert fast genauso wie es sein sollte es sind nurnoch 2 kleinigkeiten die ich leider auch durch meine Kenntnisse nicht fixen kann.

Ich hab mich für die Variante A entschieden und nur die oberen 22 Zeilen gelöscht.

1. Nun meckert das Makro jedoch rum, da in den zu kopierenden Tabellenblättern ein paar Zellen gesperrt sind, damit man nicht ausversehen die darunterliegenden Formeln verändert. Ich bräcuhte also eine Lösung, in der vor dem kopieren der Blattschutz für das Worksheet aufgehoben wird. ( Es sollen jedoch wie es in dem Makro funktioniert nur die Werte und das Format kopiert werden.)

mit ReadOnly:=False klappt es leider nicht und auch nicht wenn ich noch IgnoreReadOnlyRecommended=:True eintage.

2. in Zelle A23 der zu kopierenden Tabellenblätter steht immer eine Überschrift die 2 Farbig ist. Die ersten 5 Buchstaben sind dabei Blau die folgenden 4-12 Buchstaben sind Schwarz. Das Makro kopiert die Überschrift komplett in Blau in die neue Datei. Ist das überhaupt möglich soetwas durch ein Makro zu formatieren?



Beste Grüße
Steffen


  

Betrifft: AW: Zusammenführung von Dateien von: fcs
Geschrieben am: 19.08.2014 15:52:56

Hallo Steffen,

passen den folgenden Abschnitt des Makros an.

Der Blattschutz wird jetzt aufgehoben und in Zelle A23 wird die Zeichenformatierung wieder hergestellt. Dabei werden die Zeichen ab dem 6. Zeichen schwarz formatiert, da die Basisfarbe der Schrift korrekt mit blau ist.

Gruß
Franz

      'wenn keine Formeln kopiert werden sollen
      wksQuelle.Unprotect Password:=""
      With wksQuelle.UsedRange
        .Value = .Value
      End With
      With wksQuelle.Range("A23")
        If Len(.Text) > 5 Then
        With .Characters(6, Len(.Text) - 5).Font
            .Color = RGB(Red:=0, Green:=0, Blue:=0)
        End With
        End If
      End With
      'Blatt in neue Mappe kopieren



  

Betrifft: AW: Zusammenführung von Dateien von: Steffen
Geschrieben am: 19.08.2014 16:24:42

Woaaaa genial Franz :-)

was man mit Excel nicht alles machen kann :-O

Klappt das auch das Excel Wörter erkennen kann? Sprich ich habe in Zelle A23 eine Überschrift diese hat immer folgendes Muster: "Wort - Wort".

nun soll das

1. Wort blau,
der "-" blau und das
2. Wort die ersten 5 Buchstaben blau alle weiteren Buchstaben Schwarz?


  

Betrifft: AW: Zusammenführung von Dateien von: fcs
Geschrieben am: 19.08.2014 17:58:22

Hallo Steffen,

mit variabler Färbung der Zeichen sieht es so aus:

      'wenn keine Formeln kopiert werden sollen
      wksQuelle.Unprotect Password:=""
      With wksQuelle.UsedRange
        .Value = .Value
      End With
      With wksQuelle.Range("A23")
        If InStr(1, .Text, "-") > 0 Then
          'Bindestrich im Text vorhanden - ab 6. Zeichen nach dem Bindestrich schwarz
          Spalte_L = InStr(1, .Text, "-") + 7
        Else
          'kein Bindestrich im Text - ab 6. Zeichen schwarz
          Spalte_L = 6
        End If
        If Len(.Text) >= Spalte_L Then
          With .Characters(Spalte_L, Len(.Text) - (Spalte_L - 1)).Font
              .Color = RGB(Red:=0, Green:=0, Blue:=0)
          End With
        End If
      End With
      'Blatt in neue Mappe kopieren

Gruß
Franz


 

Beiträge aus den Excel-Beispielen zum Thema "Zusammenführung von Dateien"