Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1456to1460
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

Tabellenblätter mehrfach kopieren- weitere Fuktion

Tabellenblätter mehrfach kopieren- weitere Fuktion
08.11.2015 23:22:12
Stefan
Hallo ich habe bereits durch eure Hilfe ein Makro bekommen das auch super funktioniert siehe Link darunter
https://www.herber.de/forum/archiv/1448to1452/t1449681.htm
Jetzt möchte ich noch eine kleine Änderung bzw. Anpassung.
Ich habe in der Mitarbeiterliste in den Zellen A1:A29 den Nachnamen des Mitarbeiters stehen. Anhand von diesen Namen wird meine Vorlage kopiert und nach dem Mitarbeiter benannt. In die Zelle B2 kopiert sich dann auch nochmal der Name des Mitarbeiters.
Jetzt hätte ich gerne das er mir in die Zelle B2 auch den Vornamen kopiert. Das heißt Mitarbeiter Mayer Thomas, soll das Tabellenblatt Mayer heißen das er kopiert und in B2 Soll Mayer Thomas stehen.
Wie kann man das noch machen, muss ich in der Mitarbeiterliste die Namen in 2 Zellen Schreiben? Oder kann man den in einer Zelle schreiben und er trennt den Namen beim kopieren?
Ich hoffe es kann mir jemand Helfen. Anbei der jetzige Code
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Sub makeSheets()
Range("A1:A33").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("A1:A32")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Dim objTemplate As Worksheet
Dim rng As Range, strName 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("A1:A29")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim$(rng.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") = 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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenblätter mehrfach kopieren- weitere Fuktion
10.11.2015 19:50:08
Stefan
Hat den niemand eine Idee und kann mir helfen?

Ansichtssache
11.11.2015 15:00:16
Michael
Hi Stefan,
wenn Du eine zweite Spalte für den Vornamen benutzt, brauchst Du natürlich nichts zu programmieren.
Dann DIMst Du einfach eine Variable "strVorname as String", so daß die Dim-Zeile so aussieht...
 Dim rng As Range, strName As String, strVorname as String

... liest ihn an passender Stelle ein, also direkt nach dem strName...
strName = Left(Trim(rng.Text), 31)
strVorname = Left(Trim(rng.Offset(0,1).Text), 31)

(offset nimmt die Zelle rechts daneben, und es gibt übrigens auch ein Ltrim, das Leerzeichen links entfernt)
... und fügst ihn mit ein, also dann:
 .Range("B2") = strVorname & " " & strName
Übrigens bist Du Dir anscheinend etwas uneins, wieviele Namen Du hast: das erste Select (kannst Du übrigens löschen) geht bis A33, sortiert wird bis A32, und übernehmen tust Du bis A29.
Schöne Grüße,
Michael

Anzeige
AW: Ansichtssache
11.11.2015 21:14:33
Stefan
Hallo Michael!
Vielen Dank für deine Antwort. Du hast Recht, da sich die Liste bzw. die Anzahl der Mitarbeiter verändern kann war ich mir nicht sicher wieviele Felder ich brauchen werde, und die Sortierfunktion hab ich mir dann einfach reinkopiert und nicht mehr genau geschaut.
Aber hab es jetzt geändert und den Code angepasst und es funktioniert super.
So schaut mein Code jetzt aus, vielleicht braucht mal jemand sowas ähnliches. Vielen Dank für deine Hilfe!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Sub makeSheets()
Range("A1:B33").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"A1:A23"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("A1:B23")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").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("A1:A33")
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
gerne, vielen Dank für die Rückmeldung owT
12.11.2015 15:14:25
Michael

38 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige