PDA

Vollständige Version anzeigen : Hilfe bei einigen/vielen Makros !Hilflos!


Sheepawookee
15.08.2016, 14:58
Hallöchen,
ich hoffe ich finde hier irgendwie Hilfe und zwar soll ich ein Handout/Handbuch (in welchem die Makros erklärt werden) zu den nachfolgenden Makros schreiben da ein werter Exkollege längere Zeit an einer Exceldatei gearbeitet hat und naja nun weg ist.
Er hat natürlich keinen eingeweiht was sich hinter all den Sachen verbirgt.
Und ich bin der einzige der sich einigermaßen gut mit Excel auskennt bzw. sich mit ganz kleinen Schritten in die Welt der Makros begibt. Natürlich möchte ich nicht das jemand anderes meine Arbeit mehr macht, nur sieht das ganze für mich auf dem ersten Blick sehr kompliziert aus. Es sind mehrere Module, bei einige konnte ich die bedeutung schon selebr herausfinden, diese vermerke ich hier nicht mehr.

Ich habe mich auch schon mit der VBA-Hilfe beschäftigt, nur komme ich dort auch nicht wirklich mit allen Begriffen zurecht.

Nr.1
Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Sub UserName()
Dim Buffer As String * 100
Dim BuffLen As Long

BuffLen = 100
GetUserName Buffer, BuffLen

'Windows Benutzernamen hier anpassen
If Left(Buffer, BuffLen - 1) = "schaefer" Then
Call Blattschutz_alle_Tabellen_aufheben
Sheets("Projektplanung").Activate
MsgBox "Hallo großer Meister! ", , "Es ist: " & Time
Call Start_Admin
Else
Call Start_sonstige

End If

End Sub

Sub Blattschutz_alle_Tabellen_aufheben()

Sheets("Rohdaten").Select
ActiveSheet.Unprotect "blau"
Range("J1").AutoFilter Field:=10, Criteria1:="<100"



End Sub


Sub Blattschutz_alle_Tabellen()

Sheets("Rohdaten").Select
ActiveSheet.Unprotect "blau"
Range("J1").AutoFilter Field:=10, Criteria1:="<100"
ActiveSheet.Protect "blau", DrawingObjects:=True, Contents:=True, Scenarios:=True


End Sub

Sub UserName2()
Dim Buffer As String * 100
Dim BuffLen As Long

BuffLen = 100
GetUserName Buffer, BuffLen

'Windows Benutzernamen hier anpassen
If Left(Buffer, BuffLen - 1) = "schaefer" Then
Call Blattschutz_alle_Tabellen_aufheben
Sheets("Projektplanung").Activate
MsgBox "Ausgeführt für schaefer!", , "Es ist: " & Time

Else
Sheets("Projektplanung").Activate
MsgBox "Verschoben!", , "Es ist: " & Time

End If

End Sub

Sub Datum()
Dim datDa As Date

datDa = "10.10.2007"
MsgBox DateSerial(Year(datDa), Month(datDa), Day(datDa) + 12)
End Sub

Sub UserName3()


Dim Buffer As String * 100
Dim BuffLen As Long

BuffLen = 100
GetUserName Buffer, BuffLen

'Windows Benutzernamen hier anpassen
If Left(Buffer, BuffLen - 1) = "schaefer" Then
Call Blattschutz_alle_Tabellen_aufheben

Else

Call Blattschutz_setzen

End If

End Sub

Nr.2

ub Bericht_Personal()

Dim olApp As Object
Dim AWS As String



ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"S:\Adressen\Leitung\Sonstiges\Nachweise\Tätigkeitsnachweis " & Range("I1").Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

AWS = "S:\Adressen\Leitung\Sonstiges\Nachweise\Tätigkeitsnachweis " & Range("C3").Value & ".pdf"

Call Ende

End Sub

Sub Bericht_Buchhaltung()

Dim olApp As Object
Dim AWS As String



ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"S:\Adressen\Leitung\Sonstiges\Nachweise\Stundenprotokoll " & Range("I1").Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

AWS = "S:\Adressen\Leitung\Sonstiges\Nachweise\Stundenprotokoll " & Range("C3").Value & ".pdf"

Call Ende

End Sub

Nr.3
Private Sub Workbook_Activate()
Application.ExecuteExcel4Macro "Show.Toolbar(""Ribbon"", False)"
End Sub

Private Sub Workbook_Deactivate()
Application.ExecuteExcel4Macro "Show.Toolbar(""Ribbon"", True)"
End Sub

Private Sub Workbook_Open()
Start = True
Call Blattschutz_alle_Tabellen_aufheben
Call Blattschutz_alle_Tabellen
Call Aufforderung
Call UserName

Dim strNutzername As String
Dim loLetzte As Long
strNutzername = Environ("Username")
With Worksheets("Protokoll")
If IsEmpty(.Cells(65536, 1)) Then
loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
loLetzte = loLetzte + 1
.Cells(loLetzte, 1).Value = strNutzername
.Cells(loLetzte, 2).Value = Now

End If
End With
Sheets("Projektplanung").Activate
'Worksheets("Projektplanung").ScrollArea = "A1:O500"


End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Sheets("Projektplanung").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Mitarbeiter").CurrentPage _
= "(All)"

Sheets(2).Activate
ActiveSheet.Unprotect "blau"
Range("J1").AutoFilter Field:=10, Criteria1:="<>"
Range("J1").AutoFilter Field:=10, Criteria1:="<2"

Call Blattschutz_alle_Tabellen

Sheets(1).Activate

Application.OnTime EarliestTime:=Startzeit, Procedure:="Aufforderung", Schedule:=False

Dim strNutzername As String
Dim loLetzte As Long
strNutzername = Environ("Username")
With Worksheets("Protokoll")
If IsEmpty(.Cells(65536, 1)) Then
loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
loLetzte = loLetzte + 1
.Cells(loLetzte, 1).Value = strNutzername
.Cells(loLetzte, 3).Value = Now

End If

End With

'Call Ende

End Sub





Private Sub Workbook_PivotTableCloseConnection(ByVal Target As Pivottable)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)

End Sub

Private Sub Workbook_Sync(ByVal SyncEventType As Office.MsoSyncEventType)

End Sub

Private Sub Workbook_WindowResize(ByVal Wn As Window)

End Sub

Nr. 4 Sehr lang

Sub Worksheet_Activate()
Dim pt As Pivottable
For Each pt In ActiveSheet.PivotTables
pt.RefreshTable
Next pt
End Sub





Private Sub CommandButton10_Click()


Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
Call Blattschutz_aufheben
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 10).Value = Date
'InputBox("Bitte geben Sie den aktuellen Wochentag ein (z.B. Mo)", "Wochentag", Format(Date, "Ddd"))
job = Zelle.Offset(0, 1).Value
strNutzername = Environ("Username")
Zelle.Offset(0, 14).Value = strNutzername
Call Blattschutz_setzen
Range("K5").Value = "Datum wurde auf morgen gesetzt"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With

End If
Sheets("Projektplanung").Select
ActiveSheet.PivotTables("PivotTable1").RefreshTable

Call UserName2

End Sub



Private Sub CommandButton11_Click()

End Sub

Private Sub CommandButton2_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 9).Value = 100
Range("K5").Value = "wurde auf 100% gesetzt"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable
End Sub

Private Sub CommandButton1_Click()

'Dim zelle As Range
'ID = ActiveCell.Value

'If ID > 0 Then

'Range("G5").Value = ID
'With Sheets("Rohdaten").Range("a1:a90000")
'Set zelle = .Find(ID, LookIn:=xlValues)
'If Not zelle Is Nothing Then
' firstaddress = zelle.Address
'Set zelle = .FindNext(zelle)
'If zelle.Address <> firstaddress Then
'Range("K5").Value = "ist nicht einzigartig"
'Else
'Sheets("Rohdaten").Activate
'zelle.Offset(0, 6).Activate
'job = zelle.Offset(0, 1).Value
'Range("I2").Value = "wurde für Zeitbearbeitung ausgewählt"
'Range("K5").Value = job
'End If
'Else
'Range("I2").Value = "wurde nicht gefunden"
'End If
'End With
'End If

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 6).Value = InputBox("Bitte tragen Sie die gewünschte Zeit ein!", "Zeit", "0:00")
Range("K5").Value = "wurde die Zeit bearbeitet"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable

End Sub



Private Sub CommandButton3_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 9).Value = 1
Range("K5").Value = "wurde auf 1% gesetzt"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable
End Sub

Private Sub CommandButton4_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 12).Value = InputBox("Bitte tragen Sie die gewünschte Menge ein!" & vbCr & "Bitte beachte das Vorzeichen +/- !", "Menge", "0")
Range("K5").Value = "wurde die Menge bearbeitet"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable

End Sub

Private Sub CommandButton5_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 4).Value = InputBox("Bitte tragen Sie die gewünschte Kostenstelle ein!", "Kostenstelle", "STI")
Range("K5").Value = "wurde die Kostenstelle bearbeitet"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable

End Sub

Private Sub CommandButton6_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 9).Value = 100
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 6).Value = 0
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 12).Value = 0
Range("K5").Value = "wurde auf 0:00 gesetzt und abgeschlossen"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable
End Sub


Private Sub CommandButton7_Click()


Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
Call Blattschutz_aufheben
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 10).Value = Date + 1
'InputBox("Bitte geben Sie den aktuellen Wochentag ein (z.B. Mo)", "Wochentag", Format(Date, "Ddd"))
job = Zelle.Offset(0, 1).Value
strNutzername = Environ("Username")
Zelle.Offset(0, 14).Value = strNutzername
Call Blattschutz_setzen
Range("K5").Value = "Datum wurde auf morgen gesetzt"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With

End If
Sheets("Projektplanung").Select
ActiveSheet.PivotTables("PivotTable1").RefreshTable

Call UserName2

End Sub

Private Sub CommandButton8_Click()

'Call Blattschutz_alle_Tabellen_aufheben
'Call UserName3

'MsgBox "Ich habe Dich doch gebeten hier nicht drauf zu drücken! :-("
Sheets("Projektplanung").Select
Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
Sheets("Rohdaten").Activate
Zelle.Offset(0, 0).Activate
Range("K5").Value = "ID wurde gesucht"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

End Sub

Private Sub CommandButton9_Click()

Dim Zelle As Range
ID = ActiveCell.Value

If ID > 0 Then

Range("G5").Value = ID
With Sheets("Rohdaten").Range("a1:a90000")
Set Zelle = .Find(ID, LookIn:=xlValues)
If Not Zelle Is Nothing Then
firstaddress = Zelle.Address
Set Zelle = .FindNext(Zelle)
If Zelle.Address <> firstaddress Then
Range("H5").Value = "ist nicht einzigartig"
Else
job = Zelle.Offset(0, 1).Value
Zelle.Offset(0, 3).Value = InputBox("Bitte tragen Sie den gewünschten Sachbearbeiter ein!", "Sachbearbeiter")
Range("K5").Value = "wurde der Sachbearbeiter bearbeitet"
Range("H5").Value = job
End If
Else
Range("K5").Value = "wurde nicht gefunden"
End If
End With
End If

ActiveSheet.PivotTables("PivotTable1").RefreshTable

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub