Frage zum Code

Informationen und Beispiele zu den hier genannten Dialog-Elementen:

Frage zum Code von Sylvio vom 19.03.2005 18:16:02

AW: Frage zum Code - von Ramses am 19.03.2005 18:28:54
- AW: Damit prüft er auf Dubletten... oT - von Hans W. Hofmann am 19.03.2005 18:33:47
  - Hübsche Variante. Danke o.T. - von Ramses am 19.03.2005 18:42:20
AW: Frage zum Code - von Sylvio am 19.03.2005 18:49:38
- AW: Frage zum Code - von Uwe Küstner am 19.03.2005 20:24:25
  - AW: Code zeigt Fehler 380! - von Sylvio am 19.03.2005 23:29:56
    - AW: Code zeigt Fehler 380! - von Uwe Küstner am 20.03.2005 00:07:39
      - AW: Code zeigt Fehler 380! - von Sylvio am 20.03.2005 00:41:06
        
        AW: Code zeigt Fehler 380! - von Uwe Küstner am 20.03.2005 15:49:14
        
        AW: Funzt! Eig.alle bis auf.....! - von Sylvio am 20.03.2005 16:59:12
        
        AW: Funzt! Eig.alle bis auf.....! - von Uwe Küstner am 20.03.2005 21:01:27
        
        AW: Funzt! Eig.alle bis auf.....! - von Sylvio am 20.03.2005 23:43:18
        
        AW: Funzt! Eig.alle bis auf.....! - von Uwe Küstner am 20.03.2005 23:57:13
        
        AW:Excel2002 - von Sylvio am 21.03.2005 11:40:01
        
        Jetzt aber ... - von Uwe Küstner am 21.03.2005 13:56:41
        
        AW: genau - von Sylvio am 21.03.2005 19:25:41
        
        und letzter Versuch mit Sortierung ;-) - von Uwe Küstner am 22.03.2005 02:16:17
        
        AW: Perfektionist? - von Sylvio am 22.03.2005 21:35:32
        
        AW: ich meine natürlich Küstner! - von Sylvio am 22.03.2005 21:45:01

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

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

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

Gruß HW

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

...

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

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

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

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

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

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

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

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

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

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).

https://www.herber.de/bbs/user/19914.xls

Gruß Uwe

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

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

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

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

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