Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 09:22:48
VBA Filter in intelligenter Tabelle funktioniert nicht
18.04.2024 08:54:52
automatisches übertragen von Daten
18.04.2024 08:16:13
Dynamische Positionsnummerierung
18.04.2024 08:15:33
Seitwärts scrollen - Fenster fixiert
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
716to720
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
716to720
716to720
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Namenliste

Namenliste
09.01.2006 20:41:22
Jürgen
Hallo
Hab mal folgendes Problem:
In einer Arbeitsmappe ist in der ersten Tabelle eine Teilnehmerliste mit Namen.
Die Namen sind numeriert. Nun möchte ich zu jedem Teilnehmer in dieser Arbeitsmappe ein Tabellenblatt erstellen welches nach der Nr. und den Namen des Teilnehmers benannt wird.
Die Tabellenblätter könnten dann so benannt sein: 3Maier oder 17Lehmann oder 34Schulz.u.s.w.
s. Beispiel
https://www.herber.de/bbs/user/29868.xls
Ich hab schon mal ein Macro dazu erstellt aber da kam laufzeitfehler 9 .
Es sollte auch funktionieren wenn die erste Tabelle mit neuen Namen erweitert wird.
Vielen Dank
Gruß Jürgen

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Namenliste
09.01.2006 20:58:09
Josef
Hallo Jürgen!
Ohne Fehlerbehandlung!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer

If Not Intersect(Target, Range("B6:B100")) Is Nothing And Target.Count = 1 Then
  If Target = "" Then Exit Sub
  blnExist = False
  intNum = Application.CountA(Range("B6:B100"))
  If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Target.Offset(0, -1) & " " & Target Then
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Worksheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Target.Offset(0, -1) & " " & Target
    Me.Activate
  End If
End If
End Sub


Die bereits vorhandenen Eingaben brauchst du ja nur mit F2 &gt ENTER durchgehen, dann werden die Tabellen angelegt!
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Namenliste
10.01.2006 14:46:53
Jürgen
Hallo Josef
Das hat ja super auf anhieb gepasst. Das hast du bestens hin bekommen.
Josef ich möchte noch ein Stück weiter gehen.
Die Zeiten von bis in den Spalten E nud F werden von mir immerwieder aktualiesiert.
Dabei geht mir das überschriebene Datum verloren. Wie kann man das alte Datum mit einer Funktion in die dazugehörige Tabelle übertragen und dort untereinander in Spalte E und F schreiben.
Beispiel s. Tabelle https://www.herber.de/bbs/user/29896.xls Zeile 13
Für eine Lösung bin ich dankbar und verbleibe mit freundlichen Gruß
Jürgen
Anzeige
AW: Namenliste
10.01.2006 16:34:33
Josef
Hallo Jürgen!
Probier mal diesen Code in der Tabelle! (ersetzt den Vorherigen!)
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet, objTar As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer, lngLast As Long
Dim rng As Range

If Not Intersect(Target, Range("B6:B100")) Is Nothing And Target.Count = 1 Then
  If Target = "" Then Exit Sub
  blnExist = False
  intNum = Application.CountA(Range("B6:B100"))
  If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
End If

If Not Intersect(Target, Range("E6:D100")) Is Nothing Then
  blnExist = False
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
  
  With objTar
    Set rng = .Range("E:E").Find(What:=Cells(Target.Row, 4), LookIn:=xlValues, lookat:=xlWhole)
    If Not rng Is Nothing Then
      rng.Offset = Cells(Target.Row, 4)
    Else
      lngLast = .Cells(Rows.Count, 5).End(xlUp).Row + 1
      If lngLast < 6 Then lngLast = 6
      .Cells(lngLast, 5) = CDate(Cells(Target.Row, 4))
      .Cells(lngLast, 6) = CDate(Cells(Target.Row, 5))
    End If
    
  End With
End If

Set objTar = Nothing
Set rng = Nothing
End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Namenliste
10.01.2006 17:40:06
Jürgen
Hallo Josef
Erst mal recht vielen Dank für deine Mühe.
Es sieht schon recht gut aus. Ein Fehler gibt es noch.
Nach dem ich das neue Datum eingetragen habe, stehen in dem dazugehörigen Tabellenblatt
4 Daten. Anfangsdatum - Uhrzeit
Anfangsdatum - Enddatum
also es werden statt zwei Daten 4 Daten übertragen.
Ist bestimmt ein kleiner Fehler.
Mit freundlichen Gruß
Jürgen
AW: Namenliste
10.01.2006 18:05:38
Josef
Hallo Jürgen!
So klappt's!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet, objTar As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer, lngLast As Long
Dim rng As Range

If Not Intersect(Target, Range("B6:B100")) Is Nothing And Target.Count = 1 Then
  If Target = "" Then Exit Sub
  blnExist = False
  intNum = Application.CountA(Range("B6:B100"))
  If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
End If

If Not Intersect(Target, Range("E6:D100")) Is Nothing Then
  blnExist = False
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
  
  With objTar
    Set rng = .Range("E:E").Find(What:=Cells(Target.Row, 4).Value, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not rng Is Nothing Then
      rng.Offset(0, 1) = Cells(Target.Row, 5)
    Else
      lngLast = .Cells(Rows.Count, 5).End(xlUp).Row + 1
      If lngLast < 6 Then lngLast = 6
      .Cells(lngLast, 5) = Cells(Target.Row, 4)
      .Cells(lngLast, 6) = Cells(Target.Row, 5)
    End If
    
  End With
End If

Set objTar = Nothing
Set rng = Nothing
End Sub


Wichtig ist, das die Zielzellen in den Tabellen mit dem Format "TT.MM.JJJJ" formatiert sind!
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Namenliste
10.01.2006 18:52:35
Jürgen
Hallo Josef
Erst mal ein ganz großes Lob an dich persönlich.Meine Bewunderung wie du VBA Programmierung beherrscht.
Das klappt tadellos.
Kanst du in der Programierung die Zellen B6 gegen B5 und B100 gegen B 1000 tauschen?
und statt Spalte E und D die Spalte P und Q einsetzen.In der Zieltabelle kann ja E und D bleiben.
Noch ne Frage geht das noch , das ich per Klick von der Teilnehmertabelle zur Namentabelle springe? also bei Meier hab ich das Datum und nun will ich zu Meier in die Tabelle. Bei 50 Namen muss ich sonst ganz schön suchen.
Dank im Voraus
mit freundlichen Gruß
Jürgen
Anzeige
AW: Namenliste
10.01.2006 19:55:36
Josef
Hallo Jürgen!
Mit Doppelklick auf einen Namen in Spalte B, gelangst du zum jeweiligen Sheet!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 2 And Target.Row > 4 Then
  Cancel = True
  On Error Resume Next
  Sheets(Target.Offset(0, -1) & " " & Target).Activate
End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet, objTar As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer, lngLast As Long
Dim rng As Range

If Not Intersect(Target, Range("B5:B1000")) Is Nothing And Target.Count = 1 Then
  If Target = "" Then Exit Sub
  blnExist = False
  intNum = Application.CountA(Range("B5:B1000"))
  If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
End If

If Not Intersect(Target, Range("E6:D100")) Is Nothing Then
  blnExist = False
  For Each objSh In ThisWorkbook.Worksheets
    If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
      Set objTar = objSh
      blnExist = True
      Exit For
    End If
  Next
  If Not blnExist Then
    Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
    objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
    Me.Activate
  End If
  
  With objTar
    Set rng = .Range("E:E").Find(What:=Cells(Target.Row, 16).Value, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not rng Is Nothing Then
      rng.Offset(0, 1) = Cells(Target.Row, 17)
    Else
      lngLast = .Cells(Rows.Count, 5).End(xlUp).Row + 1
      If lngLast < 6 Then lngLast = 6
      .Cells(lngLast, 5) = Cells(Target.Row, 16)
      .Cells(lngLast, 6) = Cells(Target.Row, 17)
    End If
    
  End With
End If

Set objTar = Nothing
Set rng = Nothing
End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Namenliste
10.01.2006 20:30:35
Jürgen
Hallo Sepp
mit dem doppelkick das klapp, aber jetzt werden die Daten von P und Q nicht mehr in der Zieltabelle gespeichert bzw. untereinander geschrieben.
Dank im voraus
Gruß Jürgen
AW: Namenliste
10.01.2006 20:33:19
Josef
Hallo Jürgen!
Sorry, ich hab' vergessen den Bezug anzupassen!
Statt

Range("E6:D100")

muss es

Range("P5:Q1000")

heissen!
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Namenliste
10.01.2006 21:01:14
Jürgen
jetzt hat's geklappt.
Hallo Sepp, Josef Ehrensberger
und eigendlich das gesamte Team der Excelexperten!!!
Ich glaube im Namen aller Teilnehmer zu sprechen
so möchte ich dem gesamten Team des Excelforums für Ihre fleisige
und zuverlässige Hilfe und Arbeit ein großes Dankeschön übermitteln.
Mit freundlichen Gruß
Jürgen

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige