Mindestens 2 Eingaben für Makroausführung
17.07.2007 11:56:00
Salim
Hallo zusammen,
ich habe mit mehreren Beiträgen aus diesem Forum ein relativ langen Code gebastelt, der auch soweit prima funktioniert! Da es Daten aus mehreren Bereichen zusammensucht und später einen Spezialfilter braucht, um doppelte Einträge zu löschen und das Ganze zu sortieren, kann es nicht ausgeführt werden, wenn nicht mindestens 2 Einträge erfolgt sind.
Ich würde gerne einen zusätzlichen Befehl einbauen, der die vorhandenen Einträge zählt und falls diese Anzahl kleiner 2 sein sollte, erscheint eine MsgBox "Die Auswertung erfordert mindestens 2 Einträge". Ich habe den Code eingefügt.
Danke euch. Gruss Salim
Public Sub Zusammenfuehren()
Dim aBlatt As Variant
Dim iIndex As Integer
Dim lLetzte As Long
Dim lZeile_Q As Long
Dim lZeile_Z As Long
Dim WkSh_Z As Worksheet
Application.ScreenUpdating = False
aBlatt = Array("RSPLAN", "RSFC", "OFREC", "ZEIST")
Set WkSh_Z = Worksheets("Codes")
WkSh_Z.Range("A:B").Clear
For iIndex = 0 To 3
With Worksheets(aBlatt(iIndex))
lLetzte = IIf(.Range("b65536") "", 65536, .Range("b65536").End(xlUp).Row)
For lZeile_Q = 1 To lLetzte
If .Range("b" & lZeile_Q).Value "" Then
If Application.WorksheetFunction.CountIf _
(WkSh_Z.Columns(1), .Range("b" & lZeile_Q).Value) = 0 Then
lZeile_Z = lZeile_Z + 1
WkSh_Z.Range("b" & lZeile_Z).Value = .Range("b" & lZeile_Q).Value
End If
End If
Next lZeile_Q
End With
Next iIndex
WkSh_Z.Activate
WkSh_Z.Columns("b:b").Sort _
Key1:=Range("b1"), Order1:=xlAscending, _
header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Dim i As Long
Dim sp As Integer
Cells.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
sp = 2 'Spaltennummer
For i = Cells(Rows.Count, sp).End(xlUp).Row To 2 Step -1
If Cells(i, sp).Value = Cells(i - 1, sp).Value Then Rows(i).Delete Shift:=xlUp
Next i
WkSh_Z.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=WkSh_Z.Columns( _
"A:A"), CopyToRange:=WkSh_Z.Range("A1"), Unique:=True
Dim iRow%, r%
iRow = Cells(Rows.Count, 1).End(xlUp).Row
For r = iRow To 1 Step -1
If Cells(r, 1)