Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1488to1492
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Code erweitern

VBA Code erweitern
21.04.2016 17:11:18
Stefan
Hallo!
Ich möchte gerne meinen VBA-Code erweitern und bräuchte eure Hilfe dafür.
Der jetzige Code ist so aufgebaut, er kopiert mir mein Tabellenblatt das "Vorlage" heißt, aufgrund von Namen die in dem Tabellenblatt "Mitarbeiterliste" in dem Bereich B4:C35 stehen (in B4 steht der Nachname und in C4 der Vorname usw). Und kopiert/benennt die Vorlage automatisch nach den Nachnamen des Mitarbeiters, und schreibt auch in die Zelle B2 den Namen.
Jetzt kommt ein neues Tabellenblatt dazu das "Gesamt" heißt. In diesen hätte ich gern, dass in dem Bereich B4:B35 wieder der Name des einzelnen Mitarbeiters steht. Direkt neben dem Namen des Mitarbeiters also in der Zelle C4 soll die Zelle auf B44 von der Vorlage des Mitarbeiters verweisen. Und in D4 soll er auf Zelle C44 verweisen.
Bsp:
Der Name Mayer Thomas soll in B4 stehen.
In C4 soll der Verweis auf das Tabellenblatt "Mayer" "=Mayer!C44" stehen
In D4 soll der Verweis auf das Tabellenblatt "Mayer" "=Mayer!D44" stehen
Falls es schlecht verständlich ist Bitte schreiben, werde versuchen am Abend noch eine Bsp. Datei hochzuladen.
Vielen Dank schon mal jetzt für die Hilfe!
Hier noch der Code vom jetzigen Makro
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub makeSheets_Test()
Range("B4:C35").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"B4:B35"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("B4:C35")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B4").Select
Dim objTemplate As Worksheet
Dim rng As Range, strName As String, strVorname As String
On Error GoTo ErrExit
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
Set objTemplate = Sheets("Vorlage")
For Each rng In Sheets("Mitarbeiterliste").Range("B4:B35")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim(rng.Text), 31)
strVorname = Left(Trim(rng.Offset(0, 1).Text), 31)
If IsValidSheetName(strName) Then
If Not SheetExist(strName) Then
objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Unprotect ""
.Name = strName
.Visible = xlSheetVisible
.Range("B2") = strVorname & " " & strName
.Protect ""
End With
End If
End If
End If
Next
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - makeSheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code erweitern
21.04.2016 21:14:49
Werner
Hallo Stefan,
als erstes legst du dein Blatt "Gesamt" an. In diesem Blatt dann:
Folgende Formel in C4 und bis C35 nach unten Kopieren:
=WENNFEHLER(INDIREKT("'"&$B4&"'!B"&ZEILE(A1)+43);"")
Folgende Formel in D4 und bis D35 nach unten Kopieren:
=WENNFEHLER(INDIREKT("'"&$B4&"'!C"&ZEILE(A1)+43);"")
Dann in deinem Code folgende Code Zeilen zwischen .Apply und End With dazufügen:
.Apply
.Range("B4:B35").Copy Worksheets("Gesamt").Range("B4")
Application.CutCopyMode = False
End With
Das sollte es schon sein.
Gruß Werner

Anzeige
AW: VBA Code erweitern
21.04.2016 21:58:45
Stefan
Hallo Werner!
Vielen Dank für deine Antwort. Hab es gerade ausprobiert, funktioniert aber leider nicht.
Hier nochmal der geänderte Code. Hab ich es an die falsche Stelle kopiert?
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub makeSheets()
Range("B4:C35").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"B4:B35"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("B4:C35")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
.Range("B4:B35").Copy Worksheets("Gesamt").Range("B4")
Application.CutCopyMode = False
End With
Range("B4").Select
Dim objTemplate As Worksheet
Dim rng As Range, strName As String, strVorname As String
On Error GoTo ErrExit
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
Set objTemplate = Sheets("Vorlage")
For Each rng In Sheets("Mitarbeiterliste").Range("B4:B35")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim(rng.Text), 31)
strVorname = Left(Trim(rng.Offset(0, 1).Text), 31)
If IsValidSheetName(strName) Then
If Not SheetExist(strName) Then
objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Unprotect ""
.Name = strName
.Visible = xlSheetVisible
.Range("B2") = strVorname & " " & strName
.Protect ""
End With
End If
End If
End If
Next
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - makeSheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function

Anzeige
AW: VBA Code erweitern
21.04.2016 22:38:43
Werner
Hallo Stefan,
mein Fehler. Nimm die zwei Zeilen aus dem Code wieder raus und dann nach dem End With das dann rein.
Worksheets("Mitarbeiterliste").Range("B4:B35").Copy Worksheets("Gesamt").Range("B4")
Application.CutCopyMode = False
Gruß Werner

AW: VBA Code erweitern
21.04.2016 22:50:52
Stefan
Hallo Werner!
Danke für deine Hilfe!
Es dürfte noch ein kleiner Fehler drin sein, denn die Werte werden nur in der ersten Zeile im Tabellenblatt "Gesamt" ergänzt. Nicht aber für die restlichen Mitarbeiter.
Ich habe auch ein weiteren Tabellenblatt "Feiertage" das normal ausgeblendet ist. Das überschreibt er mir dann auch. Wenn es eingeblendet ist, funktioniert es aber komischerweise. So legt er mir aber noch eine 2. Vorlage an, und ändert mir den Namen vom Tabellenblatt "Feiertage" auf den Namen vom Mitarbeiter um.
Ich lade jetzt mal eine Bsp. Datei hoch, dann ist es sicher einfacher für dich.
https://www.herber.de/bbs/user/105137.xlsm

Anzeige
AW: VBA Code erweitern
22.04.2016 09:37:26
Werner
Hallo Stefan,
ich kann derzeit keine Daten runterladen (Arbeitsrechner) und komme frühestens am Wochenende wieder dazu.
Ich stelle den Beitrag weiterhin auf offen, vielleicht schaut ja mal jemand vorbei.
Ansonsten sehe ich es mir am Wochendende mal an.
Gruß Werner

AW: VBA Code erweitern
23.04.2016 12:30:47
Stefan
Hallo Werner!
Ich hab es jetzt teilweise hinbekommen. Der Fehler war im absoluten Bezug bei A1.
=WENNFEHLER(INDIREKT("'"&$B4&"'!B"&ZEILE($A$1)+43);"")
=WENNFEHLER(INDIREKT("'"&$B4&"'!C"&ZEILE($A$1)+43);"")
Das Problem, dass ich aber weiterhin habe, dass wenn ich das Arbeitsblatt "Feiertage" ausblende, dass er mir dieses beim Anlegen der Mitarbeiter mit den neuen Arbeitsblättern mir dieses überschreibt.
Auch hätte ich es gerne, dass wenn man später einen neuen Mitarbeiter hinzufügt, dass die Tabellenblätter alphabetisch sortiert werden. Da kann man in meinem VBA-Code sicher noch etwas ergänzen. Die Tabellenblätter "Gesamt" "Vorlage" "Mitarbeiterliste" und "Feiertage" sollte man Sie eingeblendet sein, sollen aber weiterhin am Anfang stehen. Nur die hinzugefügten Mitarbeiter hätte ich gern die Arbeitsblätter alphabetisch sortiert.
Ist es eigentlich auch möglich, in dem Arbeitsblatt "Gesamt" eine Verknüpfung zum jeweiligen Mitarbeiter zu machen, dass er dann automatisch auf Klick zu dem richtigen Arbeitsblatt springt? Sind über 25 Mitarbeiter und dann immer zum richtigen Arbeitsblatt scrollen wenn man es ergänzen will, ist ein wenig umständlich.
Ansonsten Bedanke ich mich jetzt schon nochmal bei dir Werner! Du hast mir schon super weitergeholfen!
Das ist jetzt noch mein geänderter Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub makeSheets()
Range("B4:C35").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"B4:B35"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("B4:C35")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Gesamt").Unprotect
Worksheets("Mitarbeiterliste").Range("B4:B33").Copy Worksheets("Gesamt").Range("B4")
Application.CutCopyMode = False
Range("B4").Select
ActiveWorkbook.Worksheets("Gesamt").Protect
Dim objTemplate As Worksheet
Dim rng As Range, strName As String, strVorname As String
On Error GoTo ErrExit
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
Set objTemplate = Sheets("Vorlage")
For Each rng In Sheets("Mitarbeiterliste").Range("B4:B35")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim(rng.Text), 31)
strVorname = Left(Trim(rng.Offset(0, 1).Text), 31)
If IsValidSheetName(strName) Then
If Not SheetExist(strName) Then
objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Unprotect ""
.Name = strName
.Visible = xlSheetVisible
.Range("B2") = strVorname & " " & strName
.Protect ""
End With
End If
End If
End If
Next
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - makeSheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function

Anzeige
AW: VBA Code erweitern
24.04.2016 15:57:45
Werner
Hallo Stefan,
folgende Änderungen:
1. Blatt Feiertage wird nicht mehr überschrieben (einfach am Beginn des Codes einblenden und am
Ende wieder ausblenden)
2. Beim Hinzufügen von weiteren Mitarbeitern werden die Blätter am Ende alphabetisch sortiert
3. Doppelklick auf den Familiennamen des Mitarbeiters im Blatt Mitarbeiterliste ruft das
entsprechende Blatt auf.
Schau dir die Datei mal an.
https://www.herber.de/bbs/user/105189.xlsm
Gruß Werner

AW: VBA Code erweitern
24.04.2016 16:02:22
Werner
Hallo Stefan,
ich habe gerade bemerkt, dass ich noch etwas vergessen habe. Nach der Codezeile
Set rngBereich = Sheets("Mitarbeiterliste").Range("B4:B35")
diese Zeile noch einfügen
If Target.Column  2 Then Exit Sub
Gruß Werner

Anzeige
AW: VBA Code erweitern
24.04.2016 17:51:50
Stefan
Hallo Werner!
Vielen Dank funktioniert echt genial :-)
Noch zu Punkt 3. Hab es jetzt auf das Tabellenblatt "Gesamt" geändert. Kann man, dass umgekehrt auch noch einrichten?
Das man bei jedem Mitarbeiter auf seinem eigenen Tabellenblatt in die Zelle B2 auf den Namen drückt, er auf das Tabellenblatt "Gesamt" springt?
Mir würde nur einfallen, ein einfaches Makro mit Button wo er mir einfach dann in das Tabellenblatt "Gesamt" wechselt.

AW: VBA Code erweitern
24.04.2016 18:01:32
Werner
Hallo Stefan,
schau ich mir morgen nochmal an.
Gruß Werner

AW: VBA Code erweitern
24.04.2016 18:23:13
Stefan
Ok vielen Dank Werner!
Hab es grad mit einem Makro probiert, der mir einfach auf das Tabellenblatt "Gesamt" wechselt. Funktioniert eigentlich auch ganz gut, perfekt wäre es wenn er dann auch in der richtigen Zeile bzw. in der Zelle vom Namen vom jeweiligen Mitarbeiter im Tabellenblatt "Gesamt" wäre.

Anzeige
AW: VBA Code erweitern
25.04.2016 11:14:53
Werner
Hallo Stefan,
ich habe jetzt ins Blatt "Gesamt" einen Ereigniscode (bei Doppelklick) eingebaut. Dieser wird dann beim Anlegen der einzelnen Blätter durch das Kopieren der Vorlage in jedes Blatt mit kopiert. Bei Doppelklick in Zelle B2 des jeweiligen Blattes wird die Tabelle "Gesamt" aufgerufen und dort der entsprechende Mitarbeitername ausgewählt.
Auf zwei Dinge musst du aber noch aufpassen:
1. Solltest du für deinen Blattschutz ein Passwort vergeben, dann musst du den Code im Blatt "Vorlage" auch entsprechend anpassen
2. Solltest du aus der hochgeladenen Datei nur den Code importieren und nicht die ganze Datei verwenden, dann musst du in deiner Datei im Blatt "Vorlage" den Blattschutz (einmalig) rausnehmen. Anschließend den Blattschutz wieder setzen und im aufgehenden Fenster bitte (wichtig) bei
--Gesperrte Zellen auswählen--
den Haken setzen. Das ist nur einmalig notwendig, natürlich bevor du die Tabellenblätter der Mitarbeiter anlegst. Sonst greift der Doppelklick nicht, weil die Zellen ja gesperrt sind.
https://www.herber.de/bbs/user/105210.xlsm
Gruß Werner

Anzeige
AW: VBA Code erweitern
25.04.2016 20:33:00
Werner
Hallo Stefan,
der Code ist natürlich nicht im Blatt "Gesamt" sondern im Blatt "Vorlage" denn die wird ja für die Blätter der Mitarbeiter kopiert.
Gruß Werner

AW: VBA Code erweitern
25.04.2016 20:48:09
Stefan
Hallo Werner!
Hab deinen Code bei mir eingebunden, und funktioniert wunderbar. Echt toll!
Vielen Dank für deine super Hilfe!

AW: Gerne und danke für die Rückmeldung. o.w.T.
25.04.2016 21:49:41
Werner

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige