Daten aus 2ter Excel Instanz kopieren

[Andreas1964]

Hallo!

Ich möchte gerne 2 Arbeitsmappen zusammenführen, was aber ja nur
bedingt geht.
Sobald eine 2te Instanz geöffnet ist, dann komme ich an diese nicht
dran. Geht das und falls ja, wie?

Mfg, Andreas.

Hier mein bisheriger Code:

Sub Dateien_Zusammenführen()
Dim OurBook As Workbook
Dim NewBook As Workbook
Dim fs, TempDir
Dim Found As Boolean

Set fs = CreateObject("Scripting.FileSystemObject")

'Mehrere Arbeitsmappen offen?
If Workbooks.Count > 1 Then
formZusammenführen.Show
For Each NewBook In Workbooks
If NewBook.Name = WBname Then
Found = True
GoTo CopyIt
End If
Next
End If

'Den User eine Datei auswählne lassen, im temporären Verzeichnis
starten
TempDir = fs.GetSpecialFolder(2)
ChDir fs.GetDriveName(TempDir)
ChDir TempDir
EName = Application.GetOpenFilename("Exceldateien (*.xls), *.xls",
Title:="Excel-Dateien zusammenführen")
If EName = False Then Exit Sub

'Datei schon geöffnet?
Found = False
For Each NewBook In Workbooks
If fs.BuildPath(NewBook.Path, NewBook.Name) = EName Then
Found = True
Exit For
End If
Next

CopyIt:
Application.ScreenUpdating = False
Set OurBook = ActiveWorkbook
If Not Found Then
Workbooks.Open Filename:=EName, ReadOnly:=True
Set NewBook = ActiveWorkbook
End If
For Each S In NewBook.Sheets
S.Copy After:=OurBook.Sheets(OurBook.Sheets.Count)
Next
If Not Found Then NewBook.Close
Application.ScreenUpdating = True
End Sub

[unknown]

Post by Andreas1964
Hallo!
Ich möchte gerne 2 Arbeitsmappen zusammenführen, was aber ja nur
bedingt geht.

Was bitte definierst du unter "zusammenführen"?
Vielleicht den inhalt der 'zweiten' Mappe an den der 'ersten' anhängen?

Post by Andreas1964
Sobald eine 2te Instanz geöffnet ist, dann komme ich an diese nicht
dran. Geht das und falls ja, wie?

Da mir dein Vorgehen nicht transparent ist kann ich nur mutmaßen.
Ich kann mühelos zwei unterschiedliche Mappen öffnen & offen halten. Ich
kann diese natürlich unterscheiden, den Inhalt der 'zweiten' erfassen
und hinten (Bnatt für Blatt quasi) in der 'ersten' ankleben.
Da ich (aus Erfahrung heraus) erst gar nicht auf die Idee käme
gleichnmige Blätter nachzukleben müsste in dem Falle zumindest
sichergestellt sein, dass es da keine Überlappungen gibt.
(M.E. kämpfen wir hier ehr mit einem logischen denn einem technischen
Problem!)

Post by Andreas1964
Mfg, Andreas.
Sub Dateien_Zusammenführen()
Dim OurBook As Workbook
Dim NewBook As Workbook
Dim fs, TempDir

Nebenher: fs und TempDir werden zu Variant-Variblen. Sollen sie das..?

Post by Andreas1964
Dim Found As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
'Mehrere Arbeitsmappen offen?

Weswegen ist das interessant..??
Mappe Ziel und Quelle müssen offen sein, nicht mehr und nicht weniger.
Ob da noch andere Mappen auf sind ist ziemlich unbedeutend.

Post by Andreas1964
If Workbooks.Count > 1 Then
formZusammenführen.Show
For Each NewBook In Workbooks
If NewBook.Name = WBname Then
Found = True
GoTo CopyIt
End If
Next
End If

Ich kann nur sagen was ich täte: Meine Zielmappe ist offen als
Ausgangsbasis, von mir aus enthät auch nur sie den relevanten Code hier.
Der Nutzer öffnet unten die Quellmappe (das kann man alle schön
verdeckt organisieren) und dann wird kopiert waraufhin sich die
Quellmappe dezent zurückzieht... Von mir aus schließt sich die Zielmappe
nun ebenfalls.
Oder der Code steckt in der "Personl.Xls" (persönlichen Abeitsmappe) und
ich greife über die Datei-Öffnen-Dialoge mir die Namen der beidne Mappen
ab. Dann kann ich im Hintergrund auf machen, kopieren, zu machen...

Post by Andreas1964
'Den User eine Datei auswählne lassen, im temporären Verzeichnis
starten
TempDir = fs.GetSpecialFolder(2)
ChDir fs.GetDriveName(TempDir)
ChDir TempDir
EName = Application.GetOpenFilename("Exceldateien (*.xls), *.xls",
Title:="Excel-Dateien zusammenführen")
If EName = False Then Exit Sub
'Datei schon geöffnet?
Found = False
For Each NewBook In Workbooks
If fs.BuildPath(NewBook.Path, NewBook.Name) = EName Then
Found = True
Exit For
End If
Next

Ich habe noch nie nach dem FileSystem-Objekt geschreien. Wenn die
Quellmappe schon offen sein sollte ließe sich das z.B. über
Window.Caption auch ermitteln; und wenn sie ein anderer auf hat dann
öffene ich sie eh gleich nur als schreibgeschützt!

Post by Andreas1964
Application.ScreenUpdating = False
Set OurBook = ActiveWorkbook
If Not Found Then
Workbooks.Open Filename:=EName, ReadOnly:=True
Set NewBook = ActiveWorkbook
End If

OurBook..? Die Zielmappe meine ich. Mir ist zu hoch warum die nicht als
"Zentrale" dient.
Oder verklebst du lustig zwei beliebige Mappen wie es erforderlich ist?
Dann ahne ich bei Blattnamen ein planmäßiges Chaos!

Was sit denn das S was hier kommt? S wie Sheet..?

Post by Andreas1964
For Each S In NewBook.Sheets
S.Copy After:=OurBook.Sheets(OurBook.Sheets.Count)
Next
If Not Found Then NewBook.Close
Application.ScreenUpdating = True
End Sub

[Andreas Killer]

Post by unknown

Post by Andreas1964
Hallo!
Ich möchte gerne 2 Arbeitsmappen zusammenführen, was aber ja nur
bedingt geht.

Was bitte definierst du unter "zusammenführen"?
Vielleicht den inhalt der 'zweiten' Mappe an den der 'ersten' anhängen?

Ja, das reicht für meine Zwecke.

Post by unknown

Post by Andreas1964
Sobald eine 2te Instanz geöffnet ist, dann komme ich an diese nicht
dran. Geht das und falls ja, wie?

Da mir dein Vorgehen nicht transparent ist kann ich nur mutmaßen.
Ich kann mühelos zwei unterschiedliche Mappen öffnen & offen halten. Ich
kann diese natürlich unterscheiden, den Inhalt der 'zweiten' erfassen
und hinten (Bnatt für Blatt quasi) in der 'ersten' ankleben.
Da ich (aus Erfahrung heraus) erst gar nicht auf die Idee käme
gleichnmige Blätter nachzukleben müsste in dem Falle zumindest
sichergestellt sein, dass es da keine Überlappungen gibt.
(M.E. kämpfen wir hier ehr mit einem logischen denn einem technischen
Problem!)

Okay, Starte mal Excel, gibt irgendwas in die Zellen ein, speichere die
Datei "Mappe1.xls" irgendwo ab und nun nochmals irgendwo ein paar Daten
ein. Nicht speichern!

Nun starte Excel nochmals mit einer leeren Arbeitsmappe! (Nicht aus der
1ten Instanz "Datei/neu" sagen!!) Gibt in "Mappe2" ein paar Daten ein.
Nicht speichern!

Nun starte Excel nochmals! Und nun schreib hier in "Mappe3" ein Makro
welches alle Tablellenblätter aus "Mappe1.xls" und "Mappe2" hier in
"Mappe3" rüberkopiert. Und bitte den aktuellen Stand, ohne die
vorherigen Mappen zu speichern.

"for each WB in WorkBooks" funzt hier leider nicht, aber vielleicht hast
Du ja eine tolle Lösung für diese simple Kopieraktion?

Mfg, Andreas.

[Thomas Ramel]

Grüezi Andreas

Andreas Killer schrieb am 20.03.2007

Post by Andreas Killer
Okay, Starte mal Excel, gibt irgendwas in die Zellen ein, speichere die
Datei "Mappe1.xls" irgendwo ab und nun nochmals irgendwo ein paar Daten
ein. Nicht speichern!
Nun starte Excel nochmals mit einer leeren Arbeitsmappe! (Nicht aus der
1ten Instanz "Datei/neu" sagen!!) Gibt in "Mappe2" ein paar Daten ein.
Nicht speichern!
Nun starte Excel nochmals! Und nun schreib hier in "Mappe3" ein Makro
welches alle Tablellenblätter aus "Mappe1.xls" und "Mappe2" hier in
"Mappe3" rüberkopiert. Und bitte den aktuellen Stand, ohne die
vorherigen Mappen zu speichern.
"for each WB in WorkBooks" funzt hier leider nicht, aber vielleicht hast
Du ja eine tolle Lösung für diese simple Kopieraktion?

Wie Stefan bereits erwähnte musst Du alle geöffneten Instanzen von Excel
durchlaufen und die Werte 'zusammensammeln'.

Was sich mir allerdings nicht erschliesst, ist der Sinn dieser
(konstruierten?) Arbeitsweise mit Excel.
Nebst den einzelnen Instanzen und dem Problem Werte von der einen in die
andere zu kopieren, läufst Du beim erneuten Starten auch immer in die
Meldung, dass die personl.xls nicht, oder nur schreibgeschützt geöffnet
werden kann.

IMO wäre es besser und macht mehr Sinn die einzelnen Mappen in *einer*
Excel-Instanz zu öffnen und dann die Werte zu kopieren.


Mit freundlichen Grüssen
Thomas Ramel

[Andreas1964]

Post by Thomas Ramel
Was sich mir allerdings nicht erschliesst, ist der Sinn dieser
(konstruierten?) Arbeitsweise mit Excel.
Nebst den einzelnen Instanzen und dem Problem Werte von der einen in die
andere zu kopieren, läufst Du beim erneuten Starten auch immer in die
Meldung, dass die personl.xls nicht, oder nur schreibgeschützt geöffnet
werden kann.
IMO wäre es besser und macht mehr Sinn die einzelnen Mappen in *einer*
Excel-Instanz zu öffnen und dann die Werte zu kopieren.

Das ist korrekt, geht aber leider nicht, da ich keinen Einfluss darauf
habe wer die Excel-Instanzen startet.

Konkret ist das so, das wir ein PPS-System namens BAAN haben und bei
dem kann ich EXCEL als Drucker auswählen.

Starte ich den Druckvorgang, dann erzeugt BAAN ein Excelfile, ruf eine
neue Instanz von Excel auf, welche dann das erzeugte Excelfile öffnet.
In Excel habe ich ein Add-In installiert mit dem ich die BAAN-Daten
nun verarbeiten und aufbereiten kann.

Starte ich nun noch einen Druckvorgang, dann habe ich eine 2te
Instanz, etc.

Damit ich nun mit den Daten was anfangen kann, brauche ich sie alle in
einer Mappe. Und zwar den aktuellen Stand der laufenden Instanzen.

@Eric: Daher auch der komische Code, der prüft ob bei der Dateiauswahl
das Excelfile nicht vielleicht doch geöffnet ist. Man muss immer mit
der Dummheit seiner User rechnen. ;-))

Mfg, Andreas.

[unknown]

Post by Andreas1964
@Eric: Daher auch der komische Code, der prüft ob bei der Dateiauswahl
das Excelfile nicht vielleicht doch geöffnet ist. Man muss immer mit
der Dummheit seiner User rechnen. ;-))

Offener können die Türen nicht sein die du damit einrennst :-))

Da ich jezt gelesen habe wo der Haken bei der Sache [auch ich ahbe Ärger
wenn mehrere Instnazen aufgehen, Word kann da bei Serienbriefen geradezu
Phänomenales vollbringen!] ist sehe ich klarer was du da alles abgrasen
musst.

[stefan onken]

Post by Andreas1964
Hallo!
Ich möchte gerne 2 Arbeitsmappen zusammenführen, was aber ja nur
bedingt geht.
Sobald eine 2te Instanz geöffnet ist, dann komme ich an diese nicht
dran. Geht das und falls ja, wie?
Mfg, Andreas.

hallo Andreas,
um an die zweite Instanz zu kommen, musst du mE alle Instanzen
durchlaufen und prüfen, ob zB im Fenstertitel "Excel" enthalten ist
(Codebsp: http://freenet-homepage.de/steonken/exceltasks.xls, im Code
GetWindowInfo entspricht Title dem Fenstertitel ).Wenn enthalten, dann
prüfen, ob Title = Application.Caption. Wenn nein, dann über GetObject
auf die Instanz zugreifen.

If InStr(Title, "Microsoft Excel") > 0 Then
If Title <> Application.Caption Then
Set xl2 = GetObject(Replace(Title, "Microsoft Excel - ", ""))
MsgBox xl2.Name
End If
End If

Gruß
stefan

[Andreas1964]

(Codebsp:http://freenet-homepage.de/steonken/exceltasks.xls, im Code
GetWindowInfo entspricht Title dem Fenstertitel ).Wenn enthalten, dann
prüfen, ob Title = Application.Caption. Wenn nein, dann über GetObject
auf die Instanz zugreifen.

Super klasse, funktioniert einwandfrei! :-))

Vielen Dank, Andreas.

[Andreas1964]

Post by stefan onken
Set xl2 = GetObject(Replace(Title, "Microsoft Excel - ", ""))

Verdammt, geht doch nicht, naja fast... 2 Haken. Ich häng meinen Code
mal unten dran. "sub Test" rufe ich auf.

1. Haken
Wenn ich in einer weiteren Instanz mehrere Excelmappen öffne, dann
komme ich nur an die zuletzt geöffnete dran. Wieso?

2. Haken
Mein BAAN druckt anscheinend nur einen Text und ändert die Dateiendung
auf .XLS und ruft dann Excel auf, welches dieses File (in meinem Fall
"excel.xls") auch ordnungsgemäß öffnet.
Die Instanz wird zwar gefunden jedoch bekomme ich bei GetObject einen

Laufzeitfehler '-2147221020 (800401e4)
Automatisierungsfehler
Ungültige Syntax

Könntet Ihr mal kucken? Danke, Andreas.

Option Explicit

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long,
ByVal wCmd As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias _
"GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String,
ByVal cch As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2

Public Task As Object

Sub Test()
Dim Wb As Workbook
Dim Handle As Long, TaskCount As Integer, Y As Integer
Cells.ClearContents
Handle = GetFirstTask
Y = 1
TaskCount = 0
Do While Handle <> 0
TaskCount = TaskCount + 1
For Each Wb In Task.Application.Workbooks
Cells(Y, 1) = "Task " & TaskCount & ": " & Wb.Name
Y = Y + 1
Next
Handle = GetNextTask(Handle)
Loop
End Sub

Public Function GetFirstTask() As Long
Dim hWnd As Long
Dim Title As String
hWnd = GetForegroundWindow()
hWnd = GetWindow(hWnd, GW_HWNDFIRST)
Do
GetWindowInfo hWnd, Title
If InStr(Title, "Microsoft Excel") > 0 Then
If Title <> Application.Caption Then
Set Task = GetObject(Replace(Title, "Microsoft Excel - ", ""))
Exit Do
End If
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = 0
GetFirstTask = hWnd
End Function

Public Function GetNextTask(ByVal hWnd As Long) As Long
Dim Title As String
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
If hWnd > 0 Then
Do
GetWindowInfo hWnd, Title
If InStr(Title, "Microsoft Excel") > 0 Then
If Title <> Application.Caption Then
Set Task = GetObject(Replace(Title, "Microsoft Excel - ",
""))
Exit Do
End If
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = 0
End If
GetNextTask = hWnd
End Function

Private Sub GetWindowInfo(ByVal hWnd&, ByRef Title As String)
Dim Result&
'Title des Fenster auslesen
Result = GetWindowTextLength(hWnd) + 1
Title = Space$(Result)
Result = GetWindowText(hWnd, Title, Result)
Title = Left$(Title, Len(Title) - 1)
End Sub

[stefan onken]

hallo Andreas,

Post by Andreas1964

Post by stefan onken
Set xl2 = GetObject(Replace(Title, "Microsoft Excel - ", ""))

Verdammt, geht doch nicht, naja fast... 2 Haken. Ich häng meinen Code
mal unten dran. "sub Test" rufe ich auf.
1. Haken
Wenn ich in einer weiteren Instanz mehrere Excelmappen öffne, dann
komme ich nur an die zuletzt geöffnete dran. Wieso?

das war mir gestern bei meinen Tests auch schon aufgefallen. ich
denke, es liegt am GetObject, mit dem man nicht auf den eigentlichen
task, sondern auf die Datei, die im Fenstertitel steht, Zugriff hat
(daher auch das Replace() bei Getobject, um den vorderen Teil des
Fenstertitels abzuschneiden).
Abhilfe wäre in Excel: Extras/Optionen/Ansicht/Fenster in Taskleiste

Task.Application.ScreenUpdating = False
Task.Application.ShowWindowsInTaskbar = True
For Each Wb In Task.Application.Workbooks
Cells(Y, 1) = "Task " & TaskCount & ": " & Wb.Name
Y = Y + 1
Task.Application.ShowWindowsInTaskbar = False
Task.Application.ScreenUpdating = True

ganz korrekt müsstest du die Einstellung von ShowWindowsInTaskbar in
eine Variable schreiben, auf True setzen und dann wieder auf die
Variable zurücksetzen

Post by Andreas1964
2. Haken
Mein BAAN druckt anscheinend nur einen Text und ändert die Dateiendung
auf .XLS und ruft dann Excel auf, welches dieses File (in meinem Fall
"excel.xls") auch ordnungsgemäß öffnet.
Die Instanz wird zwar gefunden jedoch bekomme ich bei GetObject einen
Laufzeitfehler '-2147221020 (800401e4)
Automatisierungsfehler
Ungültige Syntax

hmm, was steht denn im Fenstertitel der Excelinstanz und was macht
Replace daraus?

Gruß
stefan

Post by Andreas1964
Könntet Ihr mal kucken? Danke, Andreas.

[Andreas1964]

On 21 Mrz., 14:09, "stefan onken" <***@web.de> wrote:

Hallo Stefan.

Post by stefan onken

Post by Andreas1964
2. Haken
Laufzeitfehler '-2147221020 (800401e4)
Automatisierungsfehler
Ungültige Syntax

hmm, was steht denn im Fenstertitel der Excelinstanz und was macht
Replace daraus?

Sieht soweit alles gut aus. Im Titel der Instanz steht tatsächlich
"Microsoft Excel - dateiname.xls" und das Replace liefert ganz
ordentlich "dateiname.xls". Keine Steuerzeichen oder Ascii-Null dran,
alles sauber.

Eine Lösung wäre wenn ich den kompletten Pfad angeben könnte, also "c:
\temp\dateiname.xls" dann kommt der Fehler nicht. Nur kann man den
elegant feststellen bevor man GetObject gesagt hat?

Ich habe hier übrigens Excel 2000 (9.0.3821 SR-1) und Win2k SP4. Auf
einem anderen Rechner mit Excel 2002 und WinXP kommt der Fehler nicht!

Außerdem ist noch ein Haken aufgetaucht, der bei beiden Rechnern
kommt:

Situation: GetObject funktioniert und mein Code ist bis zum Ende
gelaufen. Nun schließe ich von Hand die 2te Instanz (also
"dateiname.xls") und kehre zur 1ten Instanz zurück. Dann kommt nach
ein paar Sekunden ein Fenster:

Titel: Dokument jetzt verfügbar
Text:
'dateiname.xls' ist jetzt verfügbar.
Wählen sie Lese/Schreibzugriff, um es zum Bearbeiten zu öffnen.
Buttons: "Lese/Schreibzugriff" und "Abbrechen"

Kann man das unterbinden?

Mfg, Andreas.

[stefan onken]

hi Andreas,

Post by Andreas1964
Sieht soweit alles gut aus. Im Titel der Instanz steht tatsächlich
"Microsoft Excel - dateiname.xls" und das Replace liefert ganz
ordentlich "dateiname.xls". Keine Steuerzeichen oder Ascii-Null dran,
alles sauber.
\temp\dateiname.xls" dann kommt der Fehler nicht. Nur kann man den
elegant feststellen bevor man GetObject gesagt hat?

gute Frage ;)
Ich hab auch noch mal etwas rumgebastelt. Bei nicht gespeicherten
Dateien im anderen task klappt GetObject gut, bei gespeicherten nur
dann, wenn die im selben Verzeichnis wie die den Code enthaltende
Datei gespeichert sind. Wenn im anderen task eine Datei geöffnet ist,
die in einem anderen Verzeichnis gespeichert ist, kommt auch bei mir
der Lauftzeitfehler/Ungültige Syntax. GetObject braucht also den
kompletten Pfad.
Ich habe aber keine Idee, wie man den rauskriegt.

Post by Andreas1964
Ich habe hier übrigens Excel 2000 (9.0.3821 SR-1) und Win2k SP4. Auf
einem anderen Rechner mit Excel 2002 und WinXP kommt der Fehler nicht!
Außerdem ist noch ein Haken aufgetaucht, der bei beiden Rechnern
Situation: GetObject funktioniert und mein Code ist bis zum Ende
gelaufen. Nun schließe ich von Hand die 2te Instanz (also
"dateiname.xls") und kehre zur 1ten Instanz zurück. Dann kommt nach
Titel: Dokument jetzt verfügbar
'dateiname.xls' ist jetzt verfügbar.
Wählen sie Lese/Schreibzugriff, um es zum Bearbeiten zu öffnen.
Buttons: "Lese/Schreibzugriff" und "Abbrechen"
Kann man das unterbinden?

wenn man (im Netzwerk) auf eine bereits von einem anderen Anwender
geöffnete Excel-Datei zugreifen will, hat man die Auswahl, sich
benachrichtigen zu lassen, wenn die Datei frei wird. Diese Nachricht
entspricht der obigen Meldung. GetObject öffnet anscheinend die
(bereits geöffnete) Datei (ohne Nachfrage), und wenn sie dann frei
wird, kommt die Meldung. Tja. ich habe mal ausprobiert, den
Objektverweis zu löschen (mit Set Task = Nothing an verschiedenen
Stellen im Code), aber genutzt hat es nichts.

Ich fürchte, mit GetObject wird das nichts. Evtl kannst du dich noch
an die VB-NG wenden, wie man Zugriff auf enen task bekommt.

Gruß
stefan

Post by Andreas1964
Mfg, Andreas.

[Andreas1964]

On 22 Mrz., 14:07, "stefan onken" <***@web.de> wrote:

Hallo Stefan.

Post by stefan onken
Ich fürchte, mit GetObject wird das nichts. Evtl kannst du dich noch
an die VB-NG wenden, wie man Zugriff auf enen task bekommt.

Okay, schaun wir mal. Vorerst habe ich eine einfachere Lösung
gefunden, ich prüfe beim Öffnen einer oder mehrerer Dateien einfach ob
sie schon geöffnet sind und gebe dem User dann die Möglichkeit zu
reagieren.

Für alle Interessierten und Mitleser hängt der Code ein Stück weiter
unten.

Vielen Dank trotzdem für Deine/Eure Hilfe.

Man liest sich. Andreas.

Private Function IsOpen(ByVal FileName As String) As Boolean
'True wenn FileName geöffnet ist
Dim slot As Integer

On Error Resume Next
slot = FreeFile
Open FileName For Binary Access Read Lock Read As #slot
IsOpen = Err.Number <> 0
Close #slot
On Error GoTo 0
End Function

Sub Dateien_Zusammenführen()
Dim OurBook As Workbook, NewBook As Workbook
Dim fs As Object
Dim TempDir As String
Dim Found As Boolean
Dim AllFileNames As Variant
Dim FName As Variant
Dim Antwort As Integer
Dim S As Variant

'Den User eine Datei auswählen lassen, im temporären Verzeichnis
starten
Set fs = CreateObject("Scripting.FileSystemObject")
TempDir = fs.GetSpecialFolder(2)
ChDir fs.GetDriveName(TempDir)
ChDir TempDir

'Datei(en) auswählen lassen
AllFileNames = Application.GetOpenFilename( _
"Exceldateien (*.xls), *.xls", Title:="Excel-Dateien
zusammenführen", MultiSelect:=True)
'Wenn AllFileNames ein Boolean ist, dann ist es false!
If VarType(AllFileNames) = vbBoolean Then Exit Sub

For Each FName In AllFileNames
'Haben wir die Datei schon selber geöffnet?
Found = False
For Each NewBook In Workbooks
If fs.BuildPath(NewBook.Path, NewBook.Name) = FName Then
Found = True
Exit For
End If
Next

'Wenn nicht, dann testen ob die Datei geöffnet ist
If Not Found Then
Do While IsOpen(FName)
Antwort = MsgBox( _
"Die Datei " & vbCrLf & FName & vbCrLf & " wird gerade von
einer anderen Instanz bearbeitet." & vbCrLf & vbCrLf & _
"Schließen Sie die gewünschte Datei in der anderen Instanz
und klicken Sie auf Wiederholen." & vbCrLf & vbCrLf & _
"Diese Fehlermeldung kann verschiedene Gründe haben:" &
vbCrLf & _
" - Die Datei ist mit einer anderen Instanz von Excel
geöffnet => Schließen Sie die anderen Exceldateien." & vbCrLf & _
" - Die Datei ist von einem anderen User geöffnet => Bitten
Sie den anderen User die Datei freizugeben." & vbCrLf & _
" - Die Datei wird von einem anderen Prozess verwendet (z.B.
BAAN druckt in diese Datei) => Schließen Sie den anderen Prozess.", _
vbExclamation + vbAbortRetryIgnore)
Select Case Antwort
Case vbAbort
Exit Sub
Case vbIgnore
GoTo NextFile
End Select
Loop
End If

Application.ScreenUpdating = False
Set OurBook = ActiveWorkbook

If Not Found Then
'Ist eine neue leere Arbeitsmappe da?
If OurBook.Path = "" And OurBook.Name = "Mappe1" And
OurBook.Saved Then
'Bei Workbooks.Open öffnet Excel die Datei und schließt
"Mappe1"
Set OurBook = Workbooks.Add
End If

'Datei öffnen
Workbooks.Open FileName:=FName, UpdateLinks:=0, ReadOnly:=True,
IgnoreReadOnlyRecommended:=True
Set NewBook = ActiveWorkbook
End If

'Tabellenblätter kopieren
For Each S In NewBook.Sheets
S.Copy After:=OurBook.Sheets(OurBook.Sheets.Count)
Next

'Ggf. das geöffnete File wieder schließen
If Not Found Then NewBook.Close
Application.ScreenUpdating = True
NextFile:
Next
End Sub