AW: Marco läuft nach Wechsel auf 2007 nicht mehr
06.05.2010 09:31:14
Alex
Guten morgen Hajo,
vielen Dank erstmal für die Antwort. Hane mir das Beispiel auch mal angeschaut und bin immer wieder erstaunt, was man alles machen kann. Aber ganz ehrlich, mich überfordert der Code bei weitem... :-)
Ich habe hier das gesamte Makro noch mal reinkopiert. Ich hoffe, es kann jemand was damit anfangen...
Sub Forecast_Erstellen()
Dim bolGrant As Boolean
Dim bolCopy As Boolean
Dim objFSO As Object
Dim strFile As String
Dim strFileS As String
Dim strPathS As String 'Source PfadDatei
Dim strPathFileS As String 'Source PfadDatei
Dim strFileT As String
Dim strPathT As String 'Target PfadDatei
Dim strPathFileT As String 'Target PfadDatei
Dim strOK As String
Dim strName As String
Dim strObjNr As String
Dim strKurzname As String
Dim strYear As String
Dim strMsg As String
Dim intAntw As Integer
' On Error GoTo ErrorHandler
Set objFSO = CreateObject("scripting.filesystemobject")
'/* Ist Auswahl getroffen
If Sheets("Forecast").Cells(6, 3) "" _
And Sheets("Forecast").Cells(6, 4) "" _
And Sheets("Forecast").Cells(6, 5) "" Then
'Koordinator
strOK = Sheets("Forecast").Cells(6, 4)
'/* Zieltabelle (Aufrufende...) ermitteln
strFileT = objFSO.GetFileName(ActiveWorkbook.FullName)
'/* Zielpfad ermitteln
strPathFileT = ActiveWorkbook.FullName
strPath = ActiveWorkbook.Path
strPath = objFSO.GetParentFolderName(strPath)
strPathT = strPath & "\Forecast_Tools_OK\" & strOK & "\"
strPathS = strPath & "\Master_AZK\"
' Berechtigung prüfen
bolGrant = Berechtigung
'##### Tabelle kopieren
If bolGrant Then
'/* Quelle definieren
strFileS = "Master_FcT.xls"
strPathFileS = strPathS & strFileS
'/* Daten einlesen
strName = Sheets("Forecast").Cells(6, 5)
strObjNr = Sheets("Forecast").Cells(6, 6)
strKurzname = Sheets("Forecast").Cells(6, 7)
strYear = Sheets("Forecast").Cells(6, 3)
'/* Ziel definieren
strFileT = "FcT" & Right(strYear, 2) & "_" & strKurzname & ".xls"
strPathFileT = strPathT & strFileT
'/* Prüfen ob Datei bereits existiert
bolCopy = False
'Dim objFileSearch As clsFileSearch
'Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = True
.Extension = "*.xls*"
.FolderPath = strPathT
.SearchLike = "*"
.SubFolders = False
' .FolderPath = "strPathT"
' .Filename = strFileT
'/* Wenn Datei bereits existiert
If .Execute > 0 Then
'/* Wenn Datei geöffnet, schließen
If IsWorkbookOpen(strFileT) Then
Workbooks(strFileT).Close
End If
'/* Fragen, ob Datei überschrieben werden soll
strMsg = "Achtung, Datei existiert bereits" & vbCrLf _
& vbCrLf _
& "Soll die Datei überschrieben werden?"
If MsgBox(strMsg, vbYesNo, "Dateiproblem!") = 6 Then
bolCopy = True
End If
Else
bolCopy = True
End If
End With
If bolCopy Then
'/* Kopieren
objFSO.copyfile strPathFileS, strPathFileT
'### Daten in neue Tabelle eintragen
'/* Tabelle öffnen
Workbooks.Open Filename:=strPathFileT
Sheets("Cockpit").Activate
With ActiveSheet
.Unprotect "dolomiten"
.[C4] = strYear
.[D2] = strObjNr
.[F2] = strName
.Protect "dolomiten"
End With
Workbooks(strFileT).Close SaveChanges:=True
End If
End If 'bolgrant
End If
EndSub:
Set objFSO = Nothing
Exit Sub
ErrorHandler:
strMsg = "Forecast-Tool konnte nicht erzeugt werden!" & vbCrLf _
& "Bitte prüfen, ob bereits geöffnet ist..."
intAntw = MsgBox(strMsg, vbOKOnly, "Dateiproblem!")
GoTo EndSub
End Sub