Herbers Excel-Forum - das Archiv

Frage zum Code

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

Betrifft: Frage zum Code
von: Sylvio

Geschrieben am: 19.03.2005 18:16:02
Hallo Experten,
habe diesen Code gefunden (original) und wollte ihn anpassen (geändert) aber irgendwas ist da falsch. Keine Ahnung was . :-(
Er sortiert nur die Combobox 2 richtig bei den anderen fehlen werte und leere Zellen werden angezeigt.
Könnt ihr helfen??
Danke im Voraus
MfG Sylvio


      
original:
Private Sub UserForm_Initialize()
   
Dim col As New Collection
   
Dim iRow As Integer
   iRow = 3
   
On Error Resume Next
   
Do Until IsEmpty(Cells(iRow, 1))
      col.Add Cells(iRow, 1), Cells(iRow, 1)
      
If Err = 0 Then
         ComboBox1.AddItem Cells(iRow, 1)
      
Else
         Err.Clear
      
End If
      iRow = iRow + 1
   
Loop
   
On Error GoTo 0
   ComboBox1.ListIndex = 0
End Sub
geändert:
Private Sub UserForm_Initialize()
   
Dim col As New Collection
   
Dim iRow As Integer
   iRow = 3
   
On Error Resume Next
   
Do Until IsEmpty(Cells(iRow, 1))
      col.Add Cells(iRow, 1), Cells(iRow, 1)
      
If Err = 0 Then
         ComboBox1.AddItem Cells(iRow, 1)
         ComboBox2.AddItem Cells(iRow, 3)
         ComboBox3.AddItem Cells(iRow, 5)
      
Else
         Err.Clear
      
End If
      iRow = iRow + 1
   
Loop
   
On Error GoTo 0
   ComboBox1.ListIndex = 0
   ComboBox2.ListIndex = 0
   ComboBox3.ListIndex = 0
End Sub 

     Code eingefügt mit Syntaxhighlighter 3.0

Bild

Betrifft: AW: Frage zum Code
von: Ramses

Geschrieben am: 19.03.2005 18:28:54
Hallo
Blöde Frage:
Was hat das mit Sortieren zu tun?
Es ist keine einzige Sortieranweisung im Code.
Das einzige was dein Code machen müsste/sollte den Wert aus der Zeile "iRow" und den Spalten A,C und E nehmen und in die Combobox einfügen.
Das sollte er auch tun, da sehe ich eigentlich keine Probleme.
Nur für warum dafür eine Collection nötig sein sollte, verstehe ich nicht.

Gruss Rainer
Bild

Betrifft: AW: Damit prüft er auf Dubletten... oT
von: Hans W. Hofmann
Geschrieben am: 19.03.2005 18:33:47

Gruß HW
Bild

Betrifft: Hübsche Variante. Danke o.T.
von: Ramses
Geschrieben am: 19.03.2005 18:42:20
...
Bild

Betrifft: AW: Frage zum Code
von: Sylvio
Geschrieben am: 19.03.2005 18:49:38
Hallo
Ok Sache verkannt. Aber er zeigt trotzdem nicht alle werte an.
Was die Collection soll weis ich nicht bin Anfänger .
Gruß Sylvio
Bild

Betrifft: AW: Frage zum Code
von: Uwe Küstner

Geschrieben am: 19.03.2005 20:24:25
Hallo Sylvio,
probier es mal so.
Jetzt wird jede Spalte für sich geprüft.
Private Sub UserForm_Initialize()
Dim col As New Collection
Dim irow As Integer
irow = 3
On Error Resume Next
Do Until Cells(irow, 1) & Cells(irow, 3) & Cells(irow, 5) = ""
col.Add Cells(irow, 1), Cells(irow, 1)
If Err = 0 Then
ComboBox1.AddItem Cells(irow, 1)
Else
Err.Clear
End If
col.Add Cells(irow, 3), Cells(irow, 3)
If Err = 0 Then
ComboBox2.AddItem Cells(irow, 3)
Else
Err.Clear
End If
col.Add Cells(irow, 5), Cells(irow, 5)
If Err = 0 Then
ComboBox3.AddItem Cells(irow, 5)
Else
Err.Clear
End If
irow = irow + 1
Loop
On Error GoTo 0
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = 0
ComboBox3.ListIndex = 0
End Sub
Gruß Uwe
Bild

Betrifft: AW: Code zeigt Fehler 380!
von: Sylvio
Geschrieben am: 19.03.2005 23:29:56
Hallo ,
der Code funzt nicht. Zeigt Laufzeitfehler 380!
Hier ist mal die Mappe die ich im Forum gefunden habe.
https://www.herber.de/bbs/user/19887.xls
Gruss Sylvio
Bild

Betrifft: AW: Code zeigt Fehler 380!
von: Uwe Küstner
Geschrieben am: 20.03.2005 00:07:39
Hallo Sylvio,
dann musst Du die Zeile
On Error Resume Next
gelöscht oder deaktiviert haben.
Denn diese Anweisung unterdrückt
diese Fehlermeldungen.
Gruß Uwe
Bild

Betrifft: AW: Code zeigt Fehler 380!
von: Sylvio
Geschrieben am: 20.03.2005 00:41:06
Hallo Uwe,
On Error Resume Next steht drin.
Wenn kein Problem kannst du dir ja mal die Mappe anschauen.siehe oben.
Habe den Code von dir dort eingefügt.
MfG Sylvio
Bild

Betrifft: AW: Code zeigt Fehler 380!
von: Uwe Küstner

Geschrieben am: 20.03.2005 15:49:14
Hallo Sylvio,
mit folgendem Code gehen keine Werte verloren:
Private Sub UserForm_Initialize()
Dim col As New Collection
Dim iRow As Integer
Dim sZeile As String
iRow = 3
On Error Resume Next
Do Until IsEmpty(Cells(iRow, 1))
sZeile = Cells(iRow, 1) & Cells(iRow, 3) & Cells(iRow, 5)
col.Add sZeile, sZeile
If Err = 0 Then
ComboBox1.AddItem Cells(iRow, 1)
ComboBox2.AddItem Cells(iRow, 3)
ComboBox3.AddItem Cells(iRow, 5)
Else
Err.Clear
End If
iRow = iRow + 1
Loop
On Error GoTo 0
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = 0
ComboBox3.ListIndex = 0
End Sub
Aber eigentlich ist das Alles nur ein Stochern im Nebel,
da Du nicht geschrieben hast, wie Du Dir die Ausgabe in den
Comboboxen vorstellst: Sollen alle oder nur nach bestimmten
Kriterien gefilterte Zeilen in die Boxen kommen?
Gruß Uwe
Bild

Betrifft: AW: Funzt! Eig.alle bis auf.....!
von: Sylvio
Geschrieben am: 20.03.2005 16:59:12
Hallo Uwe,
Jetzt geht es ohne Fehlermeldung.Danke erstmal für deine Mühe und Gedult.
Eigentlich dachte ich mir das so die CB sollten keine Doppelten Werte und keine Leerzellen anzeigen.
MfG Sylvio
Bild

Betrifft: AW: Funzt! Eig.alle bis auf.....!
von: Uwe Küstner

Geschrieben am: 20.03.2005 21:01:27
Hallo Sylvio,
so sollte es klappen:
Private Sub UserForm_Initialize()
Dim iRow As Long
Dim iColumn As Integer
Dim iLZ As Long  'letzte belegte Zeile
Dim iZ As Long 'Zeile in Schleife
Dim rngQ As Range 'Quellbereich
Dim rngZ As Range 'Zielbereich für Spezialfilter
Dim wsA As Worksheet
Set wsA = ActiveSheet
iRow = 3
Application.ScreenUpdating = False
iColumn = 1 'Spalte A für ComboBox1
iLZ = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row 'letzte belegte Zelle der Spalte
If Not iLZ < iRow Then
If iLZ = iRow Then
ComboBox1.AddItem wsA.Cells(iRow, iColumn).Value
Else
Set rngZ = Workbooks.Add(xlWorksheet).Sheets(1).Cells(1)
wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rngZ, Unique:=True
Set rngZ = rngZ.Parent.UsedRange
If rngZ.Cells(1) = rngZ.Cells(2) Then rngZ.Cells(1).Delete
rngZ.Sort rngZ  'Liste wird sortiert
If rngZ.Cells.Count = 1 Then
ComboBox1.AddItem rngZ.Value
Else
ComboBox1.List = rngZ.Cells(1).CurrentRegion.Value
End If
rngZ.Parent.Parent.Close False
End If
ComboBox1.ListIndex = 0
End If
iColumn = 3 'Spalte C für ComboBox2
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
If Not iLZ < iRow Then
If iLZ = iRow Then
ComboBox2.AddItem wsA.Cells(iRow, iColumn).Value
Else
Set rngZ = Workbooks.Add(xlWorksheet).Sheets(1).Cells(1)
wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rngZ, Unique:=True
Set rngZ = rngZ.Parent.UsedRange
If rngZ.Cells(1) = rngZ.Cells(2) Then rngZ.Cells(1).Delete
rngZ.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
rngZ.Sort rngZ  'Liste wird sortiert
If rngZ.Cells.Count = 1 Then
ComboBox2.AddItem rngZ.Value
Else
ComboBox2.List = rngZ.Value
End If
rngZ.Parent.Parent.Close False
End If
ComboBox2.ListIndex = 0
End If
iColumn = 5 'Spalte E für ComboBox3
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
If Not iLZ < iRow Then
If iLZ = iRow Then
ComboBox3.AddItem wsA.Cells(iRow, iColumn).Value
Else
Set rngZ = Workbooks.Add(xlWorksheet).Sheets(1).Cells(1)
wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rngZ, Unique:=True
Set rngZ = rngZ.Parent.UsedRange
If rngZ.Cells(1) = rngZ.Cells(2) Then rngZ.Cells(1).Delete
rngZ.Sort rngZ  'Liste wird sortiert
If rngZ.Cells.Count = 1 Then
ComboBox3.AddItem rngZ.Value
Else
ComboBox3.List = rngZ.Cells(1).CurrentRegion.Value
End If
rngZ.Parent.Parent.Close False
End If
ComboBox3.ListIndex = 0
End If
Application.ScreenUpdating = True
End Sub

Gruß Uwe
Bild

Betrifft: AW: Funzt! Eig.alle bis auf.....!
von: Sylvio

Geschrieben am: 20.03.2005 23:43:18
Hallo Uwe,
habe gleich mal wieder getestet leider mit Problem.
Kannst du dir das bitte noch mal anschauen?
Funktioniert nur wenn Excel vorher geöffnet ist. Wenn ich die Mappe direkt anklicke ohne das Excel activ ist passiert folgendes:
bei Klick auf Command Button in Tabelle1 zeigt er Laufzeitfehler ‚424’ Objekt erforderlich. Wenn ich bei der Fehlermeldung auf Beenden klicke öffnet eine neue Tabelle1 und er löscht die Werte aus A3:A bis auf den letzten den schiebt er nach A1.
Liegt der Fehler bei mir? Habe ich zu wenig oder falsche angaben gemacht?
Mfg Sylvio
Bild

Betrifft: AW: Funzt! Eig.alle bis auf.....!
von: Uwe Küstner

Geschrieben am: 20.03.2005 23:57:13
Hallo Sylvio,
ich verstehe Bahnhof. Bei mir geht das auch nur mit geöffnetem Excel.
Wie auch sonst?. Hier mal die geänderte Mappe von Dir.
Funktioniert bei mir einwandfrei(XL97).

Die Datei https://www.herber.de/bbs/user/19914.xls wurde aus Datenschutzgründen gelöscht

Gruß Uwe
Bild

Betrifft: AW:Excel2002
von: Sylvio
Geschrieben am: 21.03.2005 11:40:01
Hallo Uwe,
vielleicht funktioniert es mit Excel 2002 Version 10 so nicht.
Macht wirklich Problem wie schon beschrieben.
Mfg Sylvio
Bild

Betrifft: Jetzt aber ...
von: Uwe Küstner

Geschrieben am: 21.03.2005 13:56:41
Hallo Sylvio,
... sollte es klappen:
Private Sub UserForm_Initialize()
Dim iRow As Long
Dim iColumn As Integer
Dim Cn As New Collection
Dim iLZ As Long  'letzte belegte Zeile
Dim iZ As Long 'Zeile in Schleife
Dim rngQ As Range 'Quellbereich
Dim rngZ As Range 'Zielbereich für Spezialfilter
Dim wsA As Worksheet
Set wsA = ActiveSheet
iRow = 3
On Error Resume Next
iColumn = 1 'Spalte A für ComboBox1
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
For Each rngZ In rngQ
Cn.Add CStr(rngZ.Text), CStr(rngZ.Text)
Next rngZ
For iZ = 1 To Cn.Count
If Len(Cn(iZ)) > 0 Then ComboBox1.AddItem Cn(iZ)
Next iZ
ComboBox1.ListIndex = 0
Set Cn = Nothing
End If
iColumn = 3 'Spalte C für ComboBox2
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
For Each rngZ In rngQ
Cn.Add CStr(rngZ.Text), CStr(rngZ.Text)
Next rngZ
For iZ = 1 To Cn.Count
If Len(Cn(iZ)) > 0 Then ComboBox2.AddItem Cn(iZ)
Next iZ
ComboBox2.ListIndex = 0
Set Cn = Nothing
End If
iColumn = 5 'Spalte C für ComboBox3
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
For Each rngZ In rngQ
Cn.Add CStr(rngZ.Text), CStr(rngZ.Text)
Next rngZ
For iZ = 1 To Cn.Count
If Len(Cn(iZ)) > 0 Then ComboBox3.AddItem Cn(iZ)
Next iZ
ComboBox3.ListIndex = 0
Set Cn = Nothing
End If
On Error GoTo 0
End Sub
Gruß Uwe

https://www.herber.de/bbs/user/19944.xls
Bild

Betrifft: AW: genau
von: Sylvio
Geschrieben am: 21.03.2005 19:25:41
Hallo Uwe,
war ja echt ’ne schwere Geburt, oder?! Aber jetzt funktioniert es.
Er sortiert zwar nicht mehr aber das ist mir jetzt auch sch… egal.
Nochmals vielen Dank für deine Gedult und Mühe.
MfG Sylvio
Bild

Betrifft: und letzter Versuch mit Sortierung ;-)
von: Uwe Küstner

Geschrieben am: 22.03.2005 02:16:17
Hallo Sylvio,
und hier noch mal ein Versuch mit Sortierung:
Private Sub UserForm_Initialize()
Dim iRow As Long
Dim iColumn As Integer
Dim iLZ As Long  'letzte belegte Zeile
Dim rngQ As Range 'Quellbereich
Dim rngZ As Range 'Zeile in Schleife
Dim wsA As Worksheet
Set wsA = ActiveSheet
iRow = 3
iColumn = 1 'Spalte A für ComboBox1
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
rngQ.Copy ActiveSheet.Cells(1)
Columns(1).Sort Cells(1)
Set rngQ = Cells(1).CurrentRegion
For Each rngZ In rngQ
If rngZ.Offset(1, 0) <> rngZ Then ComboBox1.AddItem rngZ
Next rngZ
ComboBox1.ListIndex = 0
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End If
iColumn = 3 'Spalte C für ComboBox2
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
rngQ.Copy ActiveSheet.Cells(1)
Columns(1).Sort Cells(1)
Set rngQ = Cells(1).CurrentRegion
For Each rngZ In rngQ
If rngZ.Offset(1, 0) <> rngZ Then ComboBox2.AddItem rngZ
Next rngZ
ComboBox2.ListIndex = 0
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End If
iColumn = 5 'Spalte C für ComboBox3
iLZ = wsA.Cells(wsA.Rows.Count, iColumn).End(xlUp).Row 'letzte belegte Zelle der Spalte
Set rngQ = wsA.Range(wsA.Cells(iRow, iColumn), wsA.Cells(iLZ, iColumn))
If Not iLZ < iRow Then
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
rngQ.Copy ActiveSheet.Cells(1)
Columns(1).Sort Cells(1)
Set rngQ = Cells(1).CurrentRegion
For Each rngZ In rngQ
If rngZ.Offset(1, 0) <> rngZ Then ComboBox3.AddItem rngZ
Next rngZ
ComboBox3.ListIndex = 0
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End If
End Sub
Gruß Uwe
Bild

Betrifft: AW: Perfektionist?
von: Sylvio
Geschrieben am: 22.03.2005 21:35:32
Hallo Uwe,
funktioniert wunderbar!
hätte aber nicht sein brauchen. Gott sei Dank gibts ja noch Perfektionisten wie Uwe Kästner.
Nochmals vielen Dank für die Hilfe.
Mit freundlichen Gruß
Sylvio
Bild

Betrifft: AW: ich meine natürlich Küstner!
von: Sylvio

Geschrieben am: 22.03.2005 21:45:01
............
 Bild