Microsoft Excel

Herbers Excel/VBA-Archiv

Dateien zusammenführen | Herbers Excel-Forum


Betrifft: Dateien zusammenführen von: Andi
Geschrieben am: 16.08.2012 15:08:54

Hallo,

ich habe folgende Frage.
Der Inhalt der Dateien a.xls und b.xls sollen in die neu angelegte Datei c.xls zusammengeführt werden. Alle Dateien liegen im selben Verzeichnis
Das Format der Dateien a und b sind identisch und sollen so in c übernommen werden. Die Anzahl der Zeilen sind unterschiedlich.
Wie kann ich dies mit VBA lösen?

Gruß Andi

  

Betrifft: AW: Dateien zusammenführen von: fcs
Geschrieben am: 16.08.2012 18:13:12

Hallo Andi,

ein tiefer Blick ins Archiv hätte bestimmt etwas zutage gefördert.
Trotzdem hier ein Beispiel.

Gruß
Franz

Sub Zusammenfuehren()
  Dim wbQuelle As Workbook, wksQuelle As Worksheet, bolOpen As Boolean
  Dim wbZiel As Workbook, wksZiel As Worksheet, rngZiel As Range
  Dim strDatei As String, strVerzeichnis As String
  strVerzeichnis = "D:\Test"          '### anpassen ###
  'Quelldatei
  strDatei = "c.xls"                  '### anpassen ###
  'prüfen, ob datei schon geöffnet
  If wbkOpen(strDatei) = False Then
    Set wbZiel = Application.Workbooks.Open(Filename:=strVerzeichnis & "\" & strDatei)
  Else
    Set wbZiel = Application.Workbooks(strDatei)
  End If
  Set wksZiel = wbZiel.Worksheets(1)
  With wksZiel
    .UsedRange.ClearContents
    Set rngZiel = .Cells(1, 1)
  End With
  
  strDatei = "a.xls"                  '### anpassen ###
  'prüfen, ob datei schon geöffnet
  If wbkOpen(strDatei) = False Then
    Set wbQuelle = Application.Workbooks.Open(Filename:=strVerzeichnis & "\" & strDatei, _
      ReadOnly:=True)
    bolOpen = False
  Else
    Set wbQuelle = Application.Workbooks(strDatei)
      bolOpen = True
  End If
  Set wksQuelle = wbQuelle.Worksheets(1)
  
  wksQuelle.UsedRange.Copy Destination:=rngZiel
  Application.CutCopyMode = False
  If bolOpen = False Then wbQuelle.Close savechanges:=False
  
  'nächste Einfügezelle im Zielblatt
  With wksZiel
    Set rngZiel = .UsedRange.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
      lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
    If rngZiel Is Nothing Then
       Set rngZiel = .Cells(1, 1)
    Else
       Set rngZiel = .Cells(rngZiel.Row + 1, 1)
    End If
  End With
  
  strDatei = "b.xls"                  '### anpassen ###
  'prüfen, ob datei schon geöffnet
  If wbkOpen(strDatei) = False Then
    Set wbQuelle = Application.Workbooks.Open(Filename:=strVerzeichnis & "\" & strDatei, _
      ReadOnly:=True)
    bolOpen = False
  Else
    Set wbQuelle = Application.Workbooks(strDatei)
      bolOpen = True
  End If
  Set wksQuelle = wbQuelle.Worksheets(1)
  
  wksQuelle.UsedRange.Copy Destination:=rngZiel
  Application.CutCopyMode = False
  If bolOpen = False Then wbQuelle.Close savechanges:=False
  
  Set wbQuelle = Nothing: Set wksQuelle = Nothing
  Set wbZiel = Nothing: Set wksZiel = Nothing: Set rngZiel = Nothing
  
End Sub

Function wbkOpen(strName As String) As Boolean
  'prüft, ob Arbeitsmappe geöffnet
  Dim wbk As Workbook
  On Error Resume Next
  Set wbk = Workbooks(strName)
  If wbk Is Nothing Then wbkOpen = False Else wbkOpen = True
End Function



Beiträge aus den Excel-Beispielen zum Thema "Dateien zusammenführen"