AW: Blatt kopieren + unter akt. Datum einfügen
20.01.2010 13:27:45
Tino
Hallo,
kannst diesen Code mal testen.
Function CheckTabellen(strName$, oWB As Workbook) As Boolean
On Error Resume Next
CheckTabellen = oWB.Sheets(strName).Index > 0
End Function
Sub test()
Dim oWB As Workbook
Dim i As Integer, booCopy As Boolean, booNichtOffen As Boolean
On Error Resume Next
'Datei offen?
Set oWB = Workbooks("Ziel.xls")
On Error GoTo 0
If oWB Is Nothing Then
'Datei nicht offen
Set oWB = Workbooks.Open("D:\Ordner\Ziel.xls")
booNichtOffen = True
End If
If CheckTabellen(CStr(Date), oWB) Then
If booNichtOffen Then oWB.Close False
MsgBox "Tabelle mit den Namen '" & CStr(Date) & "' ist schon vorhanden!"
End If
If Not oWB.ReadOnly Then
For i = 1 To oWB.Sheets.Count
If IsDate(oWB.Sheets(i).Name) Then
If Date > CDate(oWB.Sheets(i).Name) Then
ThisWorkbook.ActiveSheet.Copy After:=oWB.Sheets(i)
oWB.Sheets(i + 1).Name = Date
booCopy = True
Exit For
End If
End If
Next i
If Not booCopy Then
ThisWorkbook.ActiveSheet.Copy After:=oWB.Sheets(oWB.Sheets.Count)
oWB.Sheets(oWB.Sheets.Count).Name = Date
End If
If booNichtOffen Then
oWB.Close True
Else
oWB.Save
End If
MsgBox "Tabelle erfolgreich übertragen", vbInformation
Else
If booNichtOffen Then oWB.Close False
MsgBox "Ziel ist Schreibgeschützt!", vbCritical, "Fehler"
End If
End Sub
Den Dateinamen und den Pfad musst Du im Code noch anpassen.
Ist die Datei bereits offen, wird diese verwendet.
Ist die Datei nicht offen wird diese geöffnet.
Zudem erfolgt noch eine Prüfung ob die Tabelle schon vorhanden ist.
Gruß Tino