AW: VBA Code schneller machen
18.08.2013 21:14:13
Rebecca
Hi Klaus,
klaro ... sorry ... hier der Code:
Private Sub Workbook_Open()
Application.ScreenUpdating = False
ActiveWindow.ScrollColumn = 1
Worksheets(6).Visible = True
Worksheets("Tabelle6").Select
With Cells(Sheets("Tabelle6").Cells(Rows.Count, 2).End(xlUp).Row + 1, 2)
.Select
.Value = Now & " - " & Environ("UserName")
pboNoSave = True
ActiveWorkbook.Save
End With
pboNoSave = False
Worksheets(6).Visible = False
Range("A1").Select
With Worksheets("Tabelle2")
Sheets("Tabelle2").Unprotect Password:="xxxx"
Select Case Environ("UserName")
Case "user1"
Application.ScreenUpdating = False
Worksheets("Tabelle2").Columns("AA:AB").Hidden = False
Worksheets("Tabelle3").Visible = True
Worksheets("Tabelle4").Visible = True
Worksheets("Tabelle6").Visible = True
Case "user3"
Application.ScreenUpdating = False
Worksheets("Tabelle4").Visible = False
Case Else
Application.ScreenUpdating = False
Worksheets("Tabelle2").Columns("AA:AB").Hidden = True
Worksheets("Tabelle2").Columns("AF:AN").Hidden = True
Worksheets("Tabelle3").Visible = False
Worksheets("Tabelle4").Visible = False
End Select
If .FilterMode Then .ShowAllData
Sheets("Tabelle1").EnableAutoFilter = True
Sheets("Tabelle1").Protect userinterfaceonly:=True, Password:="xxxx"
End With
Sheets("Tabelle1").Select
Range("A2").Select
dteCloseTime = Now + TimeSerial(0, 1, 0)
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 1, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 1, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 1, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If pboNoSave = True Then Exit Sub
Dim APP_OUTLOOK As Object
Dim MESSAGE As Object
Dim STR_WKB_PATH As String
Set APP_OUTLOOK = CreateObject("Outlook.Application")
Set MESSAGE = APP_OUTLOOK.CreateItem(0)
STR_WKB_PATH = ActiveWorkbook.Path
Application.Quit
Dim Mail As String
Mail_GH = "aaa@aaa.de"
Mail_GZ = "bbb@bbb.de"
Mail_n = "ccc@ccc.de"
If Zelle = "Mail_GH" Then Mail = Mail_GH
If Zelle = "Mail_GZ" Then Mail = Mail_GZ
If Zelle = "Mail_N" Then Mail = Mail_n
With MESSAGE
.to = Mail
.BCC = "ddd@ddd.de"
.Subject = "bla ... bla ... bla" & " - " & Format(Now, "DD.MM.YY HH:MM")
.HTMLBody = "bla ... bla ... bla ... bla"
.Display
End With
Set APP_OUTLOOK = Nothing
Set MESSAGE = Nothing
End Sub