Arbeiten mit Mehrfachselectionen
09.10.2003 13:17:02
Maria
ich habe das untern angehängte Makro erstellt, mit dem man eine Zahlenliste markieren kann und diese dann weiter verarbeiten kann.
Nun wollte ich das Makro so modifizieren, dass ich auch mit Mehrfachselektionen arbeiten kann - ebenfalls Zahlenlisten, aber eben zB 2 davon und mit beiden soll etwas gerechnet werden.
Ich habe versucht das mit der folgenden Definition zuzuweisen, aber dann funktioniert keine der anderen Funktionen mehr.
Dim Rng1 As Range
Dim Rng2 As Range
If Selection.Areas.Count > 1 Then
Set Rng1 = Selection.Areas.Item(1)
Set Rng3 = Selection.Areas.Item(2)
End If
Wäre schön, wenn jemand eine Idee hätte, wie man das lösen kann.
Liebe Grüße
Maria
PS hier das makro wie es vorher war
Sub Makro3()
' Makro3 Makro
' Makro am 09.10.2003 von Werk Sindelfingen aufgezeichnet
Dim Bereich As Areas
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Werteliste As New Collection
Dim Adressliste As New Collection
Dim Multliste As New Collection
Dim Str As String
Dim AnzBereich As Long
Dim i As Integer
Dim j As Integer
Dim Zaehler As Integer
Dim AnzZeilen As Integer
Dim Wertezaehler As Integer
Dim Existing As Integer
Dim Extra As Integer
Existing = 0
Zaehler = 1
AnzZeilen = 0
Wertezaehler = 1
'If Selection.Areas.Count > 1 Then
' Set Rng1 = Selection.Areas.Item(1)
' Set Rng3 = Selection.Areas.Item(2)
'End If
'das hier funktioniert noch nicht, hier möchte ich zwei selektierte Bereiche übergeben
Set Rng1 = Selection
'hiermit übergebe ich der Prozedur den ausgewählten Bereich
Rng1.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'hiermit wird der selektierte Bereich sortiert - brauchst du vermutlich nicht, dient nur meiner Kontrolle
For Each Rng2 In Rng1.Cells
'Für jeden Zelle im ausgewählten bereich wird das folgende abgearbeitet
If WorksheetFunction.Rank(Rng2.Value, Rng1) < 3 Then
Adressliste.Add Item:=Rng2.Address(RowAbsolute:=False, ColumnAbsolute:=False), Key:=CStr(Zaehler)
Zaehler = Zaehler + 1
End If
'für alle werte deren Rang kleiner 3 ist, wird die Adresse (Spalte/Reihe) gespeichert
Extra = WorksheetFunction.Rank(Rng2.Value, Rng1)
Cells(Rng2.Row, 2).Value = Extra
'hier wird der Rang zwischengespeichert nur so zum prüfen
For j = 1 To CInt(Werteliste.Count)
If Rng2.Value = Werteliste(j) Then
Existing = 1
End If
Next
If Existing = 0 Then
Werteliste.Add Item:=Rng2.Value, Key:=CStr(Wertezaehler)
Wertezaehler = Wertezaehler + 1
End If
' hier wird eine Werteliste der vorhandenen Werte erstellt
Existing = 0
AnzZeilen = AnzZeilen + 1
Next Rng2
For i = 1 To CInt(Adressliste.Count)
Extra = Range(CStr(Adressliste(i))).Value * 2
Multliste.Add Item:=Extra, Key:=CStr(i)
Next
'so kann man mit der adressenliste multiplizieren
'der rest sind prüfausgaben!!!!!!!!!!!!!!!
For i = 1 To CInt(Adressliste.Count)
Cells(i, 5).Value = Multliste(i)
Next
Cells(AnzZeilen + 1, 5).Value = "Felder mit Rang <3 jeweils mulipliziert mit 2"
For i = 1 To CInt(Adressliste.Count)
Cells(i, 3).Value = Adressliste(i)
Next
Cells(AnzZeilen + 1, 3).Value = "Adressen der Felder mit Rang <3"
For i = 1 To CInt(Werteliste.Count)
Cells(i, 4).Value = Werteliste(i)
Next
Cells(AnzZeilen + 1, 4).Value = "Werteliste"
Cells(AnzZeilen + 1, 4).Value = "Rangliste"
Cells(AnzZeilen + 2, 1).Value = AnzBereich
End Sub