MultiPage mit ListBoxen VBA

[Steffl]

Hallo Michael,

mit dem Tabstrip ist es meiner Meinung nach viel einfacher zu realisieren. Statt vielen Listboxen hast Du nur eine. Ich habe mich jetzt nur um das Tabstrip und die Listbox gekümmert. Die Userform heißt Multitabs. Ein Paar CommandButtons habe ich inaktiv gemacht, da habe ich auch den Code nicht verstanden.

[Kuwer]

Hallo Michael,

hier noch mal was von mir.
Der Code in der UF sieht so aus:

Dialog ufRegisterkarten

Option Explicit 

Private Sub CommandButton1_Click() 
 'ausgewählte Zeilen werden gelöscht 
 Dim i As Long 
 Dim varKategorie As Variant 
 With ListBox1 
   varKategorie = Range(.Tag).Cells(1).Offset(, -1).Value 
   For i = .ListCount - 1 To 0 Step -1 
     If .Selected(i) Then 
       Range(.Tag).Rows(i + 1).EntireRow.Delete 
       .RemoveItem i 
       If i = 0 Then 
         If .ListCount = 0 Then 
           Range(.Tag).Cells(1).EntireRow.Delete 
         Else 
           Range(.Tag).Cells(1).Offset(, -1).Value = varKategorie 
         End If 
       End If 
     End If 
   Next i 
 End With 
 TabStrip1_Change 
End Sub 

Private Sub CommandButton2_Click() 
 'TabOrientation ändern 
 TabStrip1.TabOrientation = (TabStrip1.TabOrientation + 1) Mod 4 
End Sub 

Private Sub CommandButton3_Click() 
 'TabStrip-Style ändern 
 TabStrip1.Style = (TabStrip1.Style + 1) Mod 3 
End Sub 

Private Sub TabStrip1_Change() 
 Dim i As Long, j As Long 
 Dim rngB As Range, rngL As Range 
 Set rngL = Range(Cells(10, 1), Cells(Rows.Count, 2).End(xlUp)) 
 If rngL.Row < 10 Then 
   MsgBox "Keine Zellen gefunden.", vbInformation 
   Exit Sub 
 End If 
 If rngL.Columns(2).Cells.Count > 1 Then 
   Set rngB = rngL.Columns(2).SpecialCells(xlCellTypeConstants) 
 Else 
   Set rngB = rngL.Columns(2) 
 End If 
 If TabStrip1.Value < rngB.Areas.Count Then 
   If rngB.Areas(TabStrip1.Value + 1).Rows.Count > 1 Then 
     ListBox1.List = rngB.Areas(TabStrip1.Value + 1).Value 
   Else 
     ListBox1.Clear 
     ListBox1.AddItem rngB.Areas(TabStrip1.Value + 1).Cells(1).Value 
   End If 
   ListBox1.Tag = rngB.Areas(TabStrip1.Value + 1).Address 
 End If 
 For i = 1 To rngB.Areas.Count 
   If i < TabStrip1.Tabs.Count Then 
     TabStrip1.Tabs(i - 1).Caption = rngB.Areas(i).Cells(1).Offset(0, -1).Value 
   End If 
 Next i 
 For j = TabStrip1.Tabs.Count - 1 To i - 1 Step -1 
   TabStrip1.Tabs(j).Visible = False 
 Next j 
End Sub 

Private Sub UserForm_Initialize() 
 ActiveSheet.Copy After:=ActiveSheet 
 TabStrip1_Change 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Typ	Name	Eigenschaften
CommandButton	CommandButton1	Caption: Auswahl löschen Height: 24 Left: 132 TabIndex: 2 Top: 234 Width: 108
CommandButton	CommandButton2	Caption: TabOrientation ändern Height: 24 Left: 294 TabIndex: 3 Top: 234 Width: 114
CommandButton	CommandButton3	Caption: TabStrip-Style ändern Height: 24 Left: 456 TabIndex: 4 Top: 234 Width: 114
ListBox	ListBox1	Height: 119,3 Left: 114 MultiSelect: 1 TabIndex: 1 Top: 36 Width: 370,05
TabStrip	TabStrip1	Height: 162 Left: 24 TabFixedWidth: 66 TabIndex: 0 TabOrientation: 2 Top: 12 Width: 552

Beispielmappe mit VBA:
  Userform mit Register_Kuwer.xlsm (Größe: 42,74 KB / Downloads: 16)

Beispielmappe ohne VBA:
  Userform mit Register_Kuwer.xlsx (Größe: 16,63 KB / Downloads: 5)

UserForm zum importieren in Mappe ohne VBA:
  ufRegisterkarten.zip (Größe: 1,96 KB / Downloads: 9)

Gruß Uwe

[michel34497]

Hallo!

Beide Vorschläge sind SUPER :28: :28: :28:
Ich Danke euch nochmals für eure mühe die ihr euch gemacht habt und :23: 

Werde es gleich einbauen und mit meinen Projekt Testen.

[michel34497]

Hallo Uwe!

Nach meinen Test ist das der Code den ich als gesucht habe.
Danke nochmals für deine Arbeit.
Wie ich auch im Forum sehe gibt es sehr viel Intresse zu diesen Thema.
Was ich noch nicht verstanden habe in dem Code ist, wie dei Tab's mit Namen befüllt werden.
In deinen Post ist ein Tab mit Registerkarte7 bezeichnet und wird dann anders beschrieben.
Der ganze Text wird ja nicht angezeigt ( ist auch so in Ordnung)

Meine Frage  ist:
Kann man den Text der gefunden wurde durch einen anderen ersetzen?
Bsp:
Gefunden Text: Sicherer Einsatz von Hydraulikschlauchleitungen nach DGUV-Regeln 113-015 Jährliche Schlauchkontrolle durch befähigte Person
Ersetzen durch: "DGUV-Regeln" oder "Hydraulikschlauchleitungen"


Als Anmerkung:

Ist nur ein Schöheitsfehler NICHT SO WICHTIG!

Freue mich schon auf die Antwort!  (Egal ob positiv oder negativ)

[Kuwer]

Hallo Michael,

hier noch einmal der komplette Code der UF mit einigen Verbesserungen und der Textersetzung per SVERWEIS(Application.VLookup) im Tabellenblatt Zuordnungen(Codename LookupTable). Wird da nichts gefunden, wird die erste Zeile der jeweiligen Liste genommen.

Solllten es mehr als 8 Abschnitte geben, musst Du entsprechend mehr Register hinzufügen. Überschüssige werden ja dann ausgeblendet.

Dialog ufRegisterkarten

Option Explicit 

Private Sub CommandButton1_Click() 
 'ausgewählte Zeilen werden gelöscht 
 Dim i As Long 
 Dim varKategorie As Variant 
 With ListBox1 
   varKategorie = Range(.Tag).Cells(1).Offset(, -1).Value 
   For i = .ListCount - 1 To 0 Step -1 
     If .Selected(i) Then 
       Range(.Tag).Rows(i + 1).EntireRow.Delete 
       .RemoveItem i 
       If i = 0 Then 
         If .ListCount = 0 Then 
           Range(.Tag).Cells(1).EntireRow.Delete 
         Else 
           Range(.Tag).Cells(1).Offset(, -1).Value = varKategorie 
         End If 
       End If 
     End If 
   Next i 
 End With 
 TabStrip1_Change 
End Sub 

Private Sub CommandButton2_Click() 
 'TabOrientation ändern 
 TabStrip1.TabOrientation = (TabStrip1.TabOrientation + 1) Mod 4 
End Sub 

Private Sub CommandButton3_Click() 
 'TabStrip-Style ändern 
 TabStrip1.Style = (TabStrip1.Style + 1) Mod 3 
End Sub 

Private Sub TabStrip1_Change() 
 Dim i As Long, j As Long 
 Dim rngB As Range, rngL As Range 
 Set rngL = Range(Cells(10, 1), Cells(Rows.Count, 2).End(xlUp)) 
 If rngL.Row < 10 Then 
   MsgBox "Keine Zellen gefunden.", vbInformation 
   Exit Sub 
 End If 
 If rngL.Columns(2).Cells.Count > 1 Then 
   Set rngB = rngL.Columns(2).SpecialCells(xlCellTypeConstants) 
 Else 
   Set rngB = rngL.Columns(2) 
 End If 
 If TabStrip1.Value < rngB.Areas.Count Then 
   If rngB.Areas(TabStrip1.Value + 1).Rows.Count > 1 Then 
     ListBox1.List = rngB.Areas(TabStrip1.Value + 1).Value 
   Else 
     ListBox1.Clear 
     ListBox1.AddItem rngB.Areas(TabStrip1.Value + 1).Cells(1).Value 
   End If 
   ListBox1.Tag = rngB.Areas(TabStrip1.Value + 1).Address 
 End If 
 For i = 1 To rngB.Areas.Count 
   If i <= TabStrip1.Tabs.Count Then 
     TabStrip1.Tabs(i - 1).Caption = MyLookup(rngB.Areas(i).Cells(1).Offset(0, -1).Value) 
     If TabStrip1.Tabs(i - 1).Caption = "" Then 
       TabStrip1.Tabs(i - 1).Caption = rngB.Areas(i).Cells(1).Value 
     End If 
   End If 
 Next i 
 For j = TabStrip1.Tabs.Count - 1 To i - 1 Step -1 
   TabStrip1.Tabs(j).Visible = False 
 Next j 
End Sub 

Private Sub UserForm_Initialize() 
 ActiveSheet.Copy After:=ActiveSheet 
 TabStrip1_Change 
End Sub 

Private Function MyLookup(Suchwert As Variant) As Variant 
 MyLookup = Application.VLookup(Suchwert, LookupTable.Range("A1").CurrentRegion, 2, 0) 
 If IsError(MyLookup) Then MyLookup = Suchwert 
End Function 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Zuordnungen

	A	B
1	Suchspalte	Ergebnisspalte
2	Elektrik	el
3	Hydraulik	hy
4	Kühlwasser	kü
5	Mechanik	me
6	Pneumatik	pn
7	Sicherer Einsatz von Hydraulikschlauchleitungen nach DGUV-Regeln 113-015 Jährliche Schlauchkontrolle durch befähigte Person	DGUV-Regeln
8	Sicherheit	si2

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8


  Userform mit Register_Kuwer_2.xlsm (Größe: 53,18 KB / Downloads: 12)

Gruß Uwe

[snb]

Verzichte auf 'merged cells' !

Alternative:

Code:

Private Sub UserForm_Initialize()
  TabStrip1_Change
End Sub

Private Sub TabStrip1_Change()
  With Tabelle7.Columns(2).SpecialCells(2)
     ListBox1.List = .Areas(TabStrip1.Value + 1).Resize(.Areas(TabStrip1.Value + 1).Count + 1).Value
     ListBox1.RemoveItem ListBox1.ListCount - 1
  End With
End Sub

Private Sub CommandButton1_Click()
  'ausgewählte Zeilen werden gelöscht
  With ListBox1
    For j = 0 To UBound(.List)
       If .Selected(j) Then Tabelle7.Columns(2).SpecialCells(2).Areas(TabStrip1.Value + 1).Cells(j + 1, 1).EntireRow.Delete
    Next
   End With
   
  TabStrip1_Change
End Sub

[michel34497]

Hallo!

:100:   :18:  :23:

Kann mich nicht richtig ausdrücken :28:
Danke!

Aber wie ich gerade sehe hat das Thema doch viele Intressiert.

[michel34497]

Hallo!

Muß das Thema nochmals einstellen.
Uwe hat mir hierbei schon sehr geholfen, doch jetzt in der Praxis stellen sich neue probleme.
Jetziger stand ist das Listbox1 mit werten aus Tabelle Test gefüllt wird und man diese auch löschen kann. Ist super wie das Funktioniert!
Die Praxis hat gezeigt, das man nicht nur die werte aus der ListBox1 löscht und dann die Tabelle Test aktualisiert wird.
Ich muß auch wieder werte hinzufügen können die mal gelöscht wurden oder neu hinzugekommen sind.

Möchte gerne eine zweite ListBox mit werten aus TabellenBlatt Data befüllen.
Dort habe ich schon einmal das Problem, ich möchte die ListBox2 genauso befüllen wie Uwe das mit der ListBox1 gemacht hat.
Nur stehen die Werte im Tabellenblatt Data nicht mehr ab Spalte B10 wie im Tabellenblatt Test, sondern ab Spalte I10
Vertsehe oder sehe nicht wie er das gemacht hat!

Wer kann da schon mal helfen?

Dann sollte es möglich sein in der ListBox2 einen Wert anzuwählen und ihn in der Listbox1 einzufügen.
Wie das funktionieren soll muß ich noch genau überlegen.
Wer vorschläge hat als her damit!