AW: Dateien zusammenführen
16.08.2012 18:13:12
fcs
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