Tabellenblätter mehrfach kopieren- weitere Fuktion

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Tabellenblätter mehrfach kopieren- weitere Fuktion
von: Stefan
Geschrieben am: 08.11.2015 23:22:12

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

Bild

Betrifft: AW: Tabellenblätter mehrfach kopieren- weitere Fuktion
von: Stefan
Geschrieben am: 10.11.2015 19:50:08
Hat den niemand eine Idee und kann mir helfen?

Bild

Betrifft: Ansichtssache
von: Michael
Geschrieben am: 11.11.2015 15:00:16
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

Bild

Betrifft: AW: Ansichtssache
von: Stefan
Geschrieben am: 11.11.2015 21:14:33
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


Bild

Betrifft: gerne, vielen Dank für die Rückmeldung owT
von: Michael
Geschrieben am: 12.11.2015 15:14:25


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Tabellenblätter mehrfach kopieren- weitere Fuktion"