AW: Makro
20.12.2005 09:42:50
Matthias
Vielen Dank!
Noch eine Frage (kenne mich in VBA leider überhaupt nicht aus):
Folgendes Makro liesst mir alle gewünschten Werte in die Combobox ein. Wie muss man das ganze umschreiben, damit die eingelesenen Werte im Blatt "Übersicht aller Werte" in der Zelle A2 abwärts aufgelistet werden?
Private Sub CommandButton1_Click()
Dim WkSh As Worksheet
Dim iBlaetter As Integer
Dim lZeilen As Long
Dim lLetzte As Long
Dim sHighValues As String
Dim iIndx As Integer
Dim sArgument As String
Dim aWerte(1000) As String
Dim iAnzahl As Long
Application.ScreenUpdating = False
For iIndx = 1 To 20
sHighValues = sHighValues & Chr(255)
Next iIndx
For iIndx = 1 To 1000
aWerte(iIndx) = sHighValues
Next iIndx
For Each WkSh In ThisWorkbook.Worksheets
If WkSh.Name <> "Startseite" And WkSh.Name <> "Übersicht aller Werte" Then
lLetzte = IIf(WkSh.Range("B65536") <> "", _
65536, WkSh.Range("B65536").End(xlUp).Row)
For lZeilen = 5 To lLetzte
If WkSh.Range("B" & lZeilen).Value <> "" Then
sArgument = CStr(WkSh.Range("B" & lZeilen).Value)
GoSub SortiertSpeichern
End If
Next lZeilen
End If
Next WkSh
For iIndx = 1 To UBound(aWerte)
If aWerte(iIndx) <> sHighValues Then iAnzahl = iAnzahl + 1
Next iIndx
'MsgBox "Anzahl Einträge ist = " & iAnzahl
With Worksheets("Übersicht aller Werte").ComboBox1
.Clear
For iIndx = 0 To iAnzahl - 1
.AddItem aWerte(iIndx + 1), iIndx
Next iIndx
.ListIndex = 0
End With
Application.ScreenUpdating = True
Exit Sub ' Ende Sub
' Daten sortiert in ein Array speichern '
SortiertSpeichern:
iIndx = 1
' Die Tabelle auf Vorhandensein der Daten absuchen '
' Es werden keine Werte doppelt in die Tabelle übernommen '
Do While iIndx <= 1000
If aWerte(iIndx) = sArgument Then ' doppelt ?
Return ' nicht speichern
Else ' kann eliminiert
If aWerte(iIndx) = sHighValues Then
GoSub SSP_Arg_Fun_Shift
Return
Else
iIndx = iIndx + 1
End If
End If ' werden!
Loop
MsgBox "Der Array der Werte ist voll.", 64, _
"zu viele Einträge."
Exit Sub
Return
' Den richtigen Platz für das neue Argument suchen bzw. schaffen '
SSP_Arg_Fun_Shift: ' Argument + Funktion
Do While iIndx > 1
If sArgument < aWerte(iIndx - 1) Then
aWerte(iIndx) = aWerte(iIndx - 1)
iIndx = iIndx - 1
Else
Exit Do ' Argument + Funktion einfügen
End If
Loop
' Die Daten in die Tabelle - auf ihren richtigen Platz - bringen '
aWerte(iIndx) = sArgument
Return
End Sub
Danke!