AW: Speichern sperren unter 2007
02.04.2016 13:50:31
chris58
Hallo !
leider habe ich noch ein "großes" Problem seit ich die Mappe für speichern gesperrt habe.
Ich habe einen Code von Rudi, der vergleicht 2 Mappen miteinander und speichert dann das Ergebnis in eine andere Datei. Bis zum Abgleich geht alles. Das Speichern geht aber nicht, da ja nur über den Speicherbutton in den beiden Mappen gespeichert werden kann.
Wie kann ich das umgehen, bzw. was muß ich voranstellen um die Speicherung zuzulassen.
Das ist eigentlich der Hauptcode für die ganze Datei.
Hier der untere Teil, wo das speichern anfängt:
Sub TP_Schreiben(strDatei As String)
Dim wkbTP As Workbook
Dim arrKeys, arrItems
Dim i As Integer, j As Integer
Dim arrTmp
Dim strSaveAS As String, iFF As Integer, strExt As String
Dim strPfad As String
Dim lFirstRow As Long, lColTrainer As Long
Dim wksHK As Worksheet, wksVS As Worksheet, wks As Worksheet
Application.ScreenUpdating = False
Set wkbTP = Workbooks.Open(strDatei)
For Each wks In wkbTP.Worksheets
Select Case LCase(wks.CodeName)
Case "tbhauptkader": Set wksHK = wks
Case "tbvorstufe": Set wksVS = wks
End Select
Next
With wkbTP
If objHK.Count Then
With wksHK
.Unprotect
arrKeys = objHK.keys
arrItems = objHK.items
lFirstRow = Application.Match("Datum", .Columns(1), 0)
lColTrainer = Application.Match("Trainer", .Rows(lFirstRow), 0)
.Cells(lFirstRow, lColTrainer).Resize(31).ClearContents
For i = 0 To UBound(arrKeys)
arrTmp = Split(arrItems(i), cstrDELIM)
For j = 0 To UBound(arrTmp)
arrTmp(j) = WorksheetFunction.Proper(arrTmp(j))
Next
.Cells(Day(arrKeys(i)) + lFirstRow, lColTrainer) = Join(arrTmp, "; ")
Next
End With
End If
If objVS.Count Then
With wksVS
.Unprotect
arrKeys = objVS.keys
arrItems = objVS.items
lFirstRow = Application.Match("Datum", .Columns(1), 0)
lColTrainer = Application.Match("Trainer", .Rows(lFirstRow), 0)
.Cells(lFirstRow, lColTrainer).Resize(31).ClearContents
For i = 0 To UBound(arrKeys)
arrTmp = Split(arrItems(i), cstrDELIM)
For j = 0 To UBound(arrTmp)
arrTmp(j) = WorksheetFunction.Proper(arrTmp(j))
Next
.Cells(Day(arrKeys(i)) + lFirstRow, lColTrainer) = Join(arrTmp, "; ")
Next
End With
End If
strPfad = .Path & "\"
strSaveAS = Left(.Name, InStrRev(.Name, ".") - 1) & "_Abgeglichen"
If Val(Application.Version) "" Then Kill strPfad & strSaveAS & strExt 'löschen _
falls vorhanden
'Punkte as Dateinamen entfernen; XL2007 ist da empfindlich
.SaveAs Filename:=strPfad & Replace(strSaveAS, ".", ""), FileFormat:=iFF
.Close
If Replace(strSaveAS, ".", "") strSaveAS Then
Name strPfad & Replace(strSaveAS, ".", "") & strExt As strPfad & strSaveAS & strExt 'ggf _
Datei umbenennen mit Punkten
End If
Application.DisplayAlerts = True
MsgBox "Datei unter " & vbLf & " " & strSaveAS & strExt & vbLf & "gespeichert.", _
vbInformation
End With
End Sub