Option Explicit Declare Function GetNetworkUserName Lib "advapi32.dll" Alias "GetUserNameA" _ (ByVal lpBuffer As String, nSize As Long) As Long Function iGetNetUserName() As String Dim MaxLen As Long, Result As Long, netUser As String netUser = String$(254, 0) MaxLen = 255 Result = GetNetworkUserName(netUser, MaxLen) iGetNetUserName = Left$(netUser, MaxLen - 1) 'MsgBo^ iGetNetUserName End Function Sub test_netuser() MsgBox iGetNetUserName If UCase(iGetNetUserName) = "AKLOTZ" Then MsgBox "Aha, Andreas Klotz! " _ & "Dir als Entwickler dieses Tools steht natürlich alles offen!" Else MsgBox "Sorry, normale Kunden haben nur eingeschränkte Rechte" End If End Sub Sub iExportPart(mySheetName As String, rangeName As String, fnam As String, FormelnAlsWerte As Variant) ' Aufgabe: save ein Range aus she=arbBlatt unter dem Namen fnam ' optional FormelNotVal: true=zellformeln als zellformeln - sonst als werte Sheets(mySheetName).Activate ThisWorkbook.Activate Range(rangeName).Select Selection.Copy Workbooks.Add [a1].Select Sheets("tabelle1").Activate If FormelnAlsWerte Then Selection.PasteSpecial Paste:=xlPasteValues Else ActiveSheet.Paste End If On Error Resume Next Kill fnam On Error GoTo 0 On Error Resume Next ActiveWorkbook.SaveAs FileName:=fnam, FileFormat:= _ xlWorkbookNormal, Password:="", CreateBackup:=False If Err.Number <> 0 Then MsgBox ("kann nicht schreiben: " + fnam) On Error GoTo 0 ActiveWorkbook.Close savechanges:=False [a1].Select 'um meldung zu vermeiden "es befinden sich große Datenmengen in Zwischenablage" End Sub Sub test_iExportPart() Call iExportPart("change", "A1:H10", "c:\temp\testpart.xls", True) End Sub Public Function Gauss_Ostern(A As Long) As Long Dim D As Long D = (((255 - 11 * (A Mod 19)) - 21) Mod 30) + 21 Gauss_Ostern = DateSerial(A, 3, 1) + D + (D > 48) + 6 - ((A + A \ 4 + _ D + (D > 48) + 1) Mod 7) End Function Sub test_Gauss_Ostern() MsgBox Format(Gauss_Ostern(2003), "dd.mm.yyyy") End Sub Sub test() Dim x For Each x In ActiveWorkbook.Names Debug.Print x.Name, x.Value ' ggf. [Strg+G]=Direct-Fenter einschalten Next ' oder auch: Next x; aber dies ist nicht zwingend notwendig End Sub Sub test_loop() Dim i As Long, b As Long i = 0: [c8] = 3 Do If i = [c8] Then Exit Do i = i + 1 MsgBox i Loop End Sub Sub test_while_loop() Dim i As Long i = 0: [c8] = 3 Do While i < [c8] i = i + 1 MsgBox i Loop End Sub Sub test_while_wend() Dim i As Long i = 0: [c8] = 3 While i < [c8] i = i + 1 MsgBox i Wend End Sub Sub test_for_next() Dim x As Long For x = 1 To 3 MsgBox x Next x End Sub Sub test_for_next_exit() Dim x As Long [c8] = 2 For x = 1 To 3 MsgBox x If x >= [c8] Then Exit For Next x End Sub Sub test_foreach() Dim x For Each x In ActiveWorkbook.Names Debug.Print x.Name, x.Value ' ggf. [Strg+G]=Direct-Fenter einschalten Next ' oder auch: Next x; aber dies ist nicht zwingend notwendig End Sub