AW: Suche/Ausgabe auf neuem Blatt
24.06.2007 09:12:22
Hajo_Zi
Hallo Regina,
ich vermute mal dies ist nur per VBA lösbar. In VBA unter der Tabelle "Suchergebnisse"
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'* H. Ziplies *
'* 24.06.07 *
'* erstellt von Hajo.Ziplies@WEB.de *
'* http://Hajo-Excel.de
If Target.Count > 1 Then Exit Sub ' mehr als eine Zelle geändert
If Target.Address "$A$2" Then Exit Sub ' Zelle verschieden von Eingabe Zelle
Dim Loletzte As Long ' Letzte belegte Zelle
Dim LoI As Long ' Schleifenvariable Zeile
Dim InI As Integer ' Schleifenvariable Spalte
Dim LoZeile As Long ' Schleifenvarible Zeile in die geschrieben _
wird, Anzahl
LoZeile = 2 ' erste Zeile in die geschrieben werden soll
' letzte belegte Zeile unabhängig von Excelversion für Spalte C (3)
Loletzte = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows. _
Count)
If Loletzte = 1 Then Loletzte = 2
Application.EnableEvents = False ' Reaktion auf Eingabe aus
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Range("B2:C" & Loletzte) = ""
With Worksheets("Test") ' erstmal alle Werte übertragen
' Letzte Zeile in Tabelle Test
Loletzte = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoI = 2 To Loletzte ' Schleife über alle Zeilen der Tabelle Test
If .Cells(LoI, 4) = Target Then ' Prüfen ob Zellinhalt = Eingabe
For InI = 17 To 23 ' Schleife über die Spalten
If .Cells(LoI, InI) "" Then
' Eingabe in Spalte A schreiben
If LoZeile = 2 Then Cells(LoZeile, 1) = Target
Cells(LoZeile, 3) = .Cells(LoI, InI)
LoZeile = LoZeile + 1
End If
Next InI
End If
Next LoI
' alle Daten übertragen, jetzt sortieren
Loletzte = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows. _
Count)
Range("C2:C" & Loletzte).Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlNo, _
MatchCase:=False, Orientation:=xlTopToBottom
' Doppelte zusammenfassen
LoZeile = 1 ' Anzahl auf 1 setzen
For LoI = Loletzte - 1 To 2 Step -1 ' Schleife über alle übertragenen Datensä _
tze
If Cells(LoI + 1, 3) = Cells(LoI, 3) Then
LoZeile = LoZeile + 1 ' Anzahl um 1 erhöhen
Rows(LoI + 1).Delete ' doppelte Zeile Löschen
Else
Cells(LoI + 1, 2) = LoZeile ' Anzahl eintragen
LoZeile = 1 ' Anzahl wieder auf 1 setzen
End If
Next LoI
Cells(2, 2) = LoZeile ' Anzahl vom ersten Datensatz eintragen
Application.EnableEvents = True ' Reaktion auf Eingabe ein
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End With
End Sub
Ich hoffe mal ich habe nichts übersehen.
Gruß Hajo