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!