Pruefen wenn Datei offen, sonst schliessen
chandler
den nachfolgenden Code habe ich in der Online-Suche gefunden und angepasst.
Function FileIsOpen(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Err = 0 And Not wkb Is Nothing Then
FileIsOpen = True
End If
On Error GoTo 0
End Function
Sub dat_exp()
'Rudi Maintaire
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim Dateiname As String
Dim Tabelle As String
ThisWorkbook.Activate
Set wsQuelle = ThisWorkbook.Worksheets("Tabelle1")
Dateiname = "Test.xls"
Tabelle = "Tabelle1"
On Error Resume Next
Application.ScreenUpdating = False
If Not FileIsOpen(Dateiname) Then
Set wsZiel = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Dateiname).Sheets(Tabelle)
End If
With Worksheets("Tabelle1")
If IsEmpty(.Cells(1, 1)) Then
i = 1
Else
i = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
wsZiel.Cells(i, 1).Value = wsQuelle.Range("A1").Value
wsZiel.Cells(i, 2).Value = wsQuelle.Range("B10").Value
wsZiel.Cells(i, 3).Value = wsQuelle.Range("C5").Value
wsZiel.Cells(i, 4).Value = wsQuelle.Range("D20").Value
End With
With ActiveWorkbook
On Error Resume Next
.Save
.Close
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
Soweit ich getestet habe funktioniert der Code, wenn aber zufaellig die Test.xls von Hand
geoeffnet wurde und das Makro ausgefuehrt wird, dann wird die Quelle-Datei geschlossen
und der Kopiervorgang findet nicht statt.
Wie koennte man im Vorfeld ueberpruefen, ob die Test.xls geoeffnet ist und gegebenenfalls
schliesst und anschliessend die Daten kopiert.
Habe nicht zur Hand Excel 2007 respektive Excel 2010 und kann daher nicht testen, ob das mit:
Function FileIsOpen(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Err = 0 And Not wkb Is Nothing Then
FileIsOpen = True
End If
On Error GoTo 0
End Function
funktioniert. Weiss jemand bescheid?
Vorab vielen Dank für Rat und Tat. Grueße Chandler