AW: msgbox erzwingen II (@Sepp)
th.heinrich
danke Sepp fuer Dein engagement,
hier alle CODES des PROJEKTES.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
'Application.DisplayAlerts = False
Dim shp As Shape
Set shp = Sheets("Besuchsbericht").Shapes("Textfeld 11") 'Blattname und Name des textfeldes anpassen
If Len(shp.TextFrame.Characters.Text) = 0 Then
MsgBox "Vor dem schliessen Besuchsinfo ausfüllen!", vbInformation, "Hinweis"
'Cancel = True
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:="\\stabifix01\ablage\tmp\Reiseberichte\" & Range("b4").Value & "_" & Range("c4").Value & "_" & Range("e1").Value & ".xls"
Sheets("besuchsbericht").Protect "ni7888"
'ThisWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
Call auslesen
End Sub
Sub auslesen() 'nebeneinander
'Application.ScreenUpdating = False
Dim rngAct As Range
Dim iCol As Integer
Dim lgrow As Long
Dim wksZiel As Worksheet
Dim wksQuell As Worksheet
On Error Resume Next
'Application.ScreenUpdating = False
Set wksQuell = ThisWorkbook.Sheets("Besuchsbericht")
Workbooks.Open Filename:="\\STABIFIX01\ablage\tmp\Reiseberichte\Datenbank\DB.xls"
'Windows("DB.xls").Activate
Sheets("tabelle1").Unprotect "ni7888"
Set wksZiel = ActiveWorkbook.Sheets("tabelle1")
With wksZiel
lgrow = .Range("a65536").End(xlUp).Row + 1
iCol = 1
For Each rngAct In wksQuell.Range("a4:f4,C6,d6,e6,d7,e7,d8,e8,f6:f8,e1,b11").Cells
.Cells(lgrow, iCol) = rngAct
iCol = iCol + 1
Next rngAct
End With
'ActiveWorkbook.Close savechanges:=True
ThisWorkbook.Close savechanges:=True
Application.CutCopyMode = False
'Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.SaveAs _
Filename:="\\stabifix01\ablage\tmp\Reiseberichte\" & Range("b4").Value & "_" & Range("c4").Value & "_" & Range("e1").Value & ".xls"
Sheets("Besuchsbericht").Protect "ni7888"
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_Open()
If Range("e1").Value = "" Then Range("e1").Value = Date
Sheets("Besuchsbericht").Protect "ni7888"
End Sub
dies wird ueber den BUTTON gestartet.
Sub SaveBook()
'Application.DisplayAlerts = False
Dim shp As Shape
Set shp = Sheets("Besuchsbericht").Shapes("Textfeld 11") 'Blattname und Name des textfeldes anpassen
If Len(shp.TextFrame.Characters.Text) = 0 Then
MsgBox "Vor dem schliessen Besuchsinfo ausfüllen!", vbInformation, "Hinweis"
Cancel = True
Else
ThisWorkbook.SaveAs Filename:="\\stabifix01\ablage\tmp\Reiseberichte\" & Range("b4").Value & "_" & Range("c4").Value & "_" & Range("e1").Value & ".xls"
Application.DisplayAlerts = True
Call auslesen
End If
End Sub
Sub auslesen() 'nebeneinander
'Application.ScreenUpdating = False
Dim rngAct As Range
Dim iCol As Integer
Dim lgrow As Long
Dim wksZiel As Worksheet
Dim wksQuell As Worksheet
On Error Resume Next
'Application.ScreenUpdating = False
Set wksQuell = ThisWorkbook.Sheets("Besuchsbericht")
Workbooks.Open Filename:="\\STABIFIX01\ablage\tmp\Reiseberichte\Datenbank\DB.xls"
'Windows("DB.xls").Activate
Sheets("tabelle1").Unprotect "ni7888"
Set wksZiel = ActiveWorkbook.Sheets("tabelle1")
With wksZiel
lgrow = .Range("a65536").End(xlUp).Row + 1
iCol = 1
For Each rngAct In wksQuell.Range("a4:f4,C6,d6,e6,d7,e7,d8,e8,f6:f8,e1,b11").Cells
.Cells(lgrow, iCol) = rngAct
iCol = iCol + 1
Next rngAct
End With
'ActiveWorkbook.Close savechanges:=True
ThisWorkbook.Close savechanges:=True
Application.CutCopyMode = False
'Application.ScreenUpdating = True
End Sub
sorry ist leider sehr viel, aber Du findest Dich sicher zurecht.
gruss thomas