AW: Bestimmte Zeile markieren
24.04.2018 22:01:23
Sandra
Hallo
Ich habe mir zu Ihrer Fragestellung etwas Gedanken gemacht und komme zum folgenden Ergebnis, wobei Ihr Problem in Bezug auf Ihre Fragestellung wirklich klein ist:
Sub Selektion_Pferderennen()
Dim wsQuelle, wsErgenis, ws As Worksheet
Dim xkeyBasis, xkeyErgebnis As Variant
Dim dicBasis, dicErgebnis As Object
Dim rngBereich, rngB, rngDatenzeile, rngDZ As Range
Dim i, lngBeginn, lngEnde, lngSpalte As Long
Dim strSpalte, strletzteSpalte, strDaten, strErgebnis As String
Dim blnWert As Boolean
'Allgemeiner Spaltenbeginn
strSpalte = "A"
'Ersten Zeile im Tabellenblatt mit den Daten
lngBeginn = 1
'Einstellung der relevanten Zeile nach dem ersten Eintrag
lngZeile = 2
'Festlegung des Tabellenblattnamens mit den Ergebnissen
strErgebnis = "Ergebnis"
Set wsQuelle = Worksheets(ActiveSheet.Name)
Set dicBasis = CreateObject("scripting.dictionary")
Set dicErgebnis = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
With wsQuelle
'Ermittlung der letzten Spalte und letzten Zeile
strletzteSpalte = Left$(Cells(lngBeginn, Cells(lngBeginn, Columns.Count).End(xlToLeft). _
Column).Address(True, False), InStr(lngBeginn, Cells(lngBeginn, Cells(lngBeginn, Columns.Count).End(xlToLeft).Column).Address(True, False), "$") - 1)
lngEnde = .Range(strSpalte & Rows.Count).End(xlUp).Row
'Damit die Ueberschriften nicht einbezogen wird, wird der Zeilenbeginn um 1 erhöht
Set rngBereich = .Range(strSpalte & lngBeginn + 1 & ":" & strSpalte & lngEnde)
'Einlessen der Einzelwerte aus dem zuvor festgelegten BEreich, wobei keine Duplicate ü _
bernommen werden
For Each rngB In rngBereich
xkeyBasis = rngB.Value
dicBasis(xkeyBasis) = 0
Next rngB
'Festlegung des Status, damit nur beim ersten Durchgang die Spaltenüberschriften eingelesen _
werden
blnWert = True
'Ermittlung des gewünschten Wertes
For Each xkeyBasis In dicBasis
For Each rngB In rngBereich
If rngB.Value = xkeyBasis Then
If blnWert = True Then
Set rngDatenzeile = .Range(strSpalte & lngBeginn & ":" & strletzteSpalte & _
lngBeginn)
'Einlesen der Ueberschrift
For Each rngDZ In rngDatenzeile
strDaten = strDaten & ";" & rngDZ.Value
Next rngDZ
'Hinzufügen der Überschriften
xkeyErgebnis = Right$(Trim(strDaten), Len(Trim(strDaten)) - 1)
dicErgebnis(xkeyErgebnis) = 0
'Aufhebung des Bereichs und leeren des Strings
Set rngDatenzeile = Nothing
strDaten = ""
'Damit die Überschrift nur einmal eingelesen wird
blnWert = False
End If
'Festlegung der Datenzeile als Bereich
Set rngDatenzeile = .Range(strSpalte & rngB.Row + lngZeile & ":" & _
strletzteSpalte & rngB.Row + lngZeile)
'Verkettung der Datenzeile als string
For Each rngDZ In rngDatenzeile
strDaten = strDaten & ";" & rngDZ.Value
Next rngDZ
'Einlesen der Zeilen
xkeyErgebnis = Right$(Trim(strDaten), Len(Trim(strDaten)) - 1)
dicErgebnis(xkeyErgebnis) = 0
strDaten = ""
Set rngDatenzeile = Nothing
'Wenn der Wert gefunden wurde, dann wird die For-Schleife verlassen
Exit For
End If
Next rngB
Next xkeyBasis
'Prüfen, ob Tabellenblatt mit Namen bereits existiert und Index des Tabellenblattes mit der _
Datenquelle ermitteln
For Each ws In Worksheets
If ws.Name = strErgebnis Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
i = 0
For Each ws In Worksheets
i = i + 1
If ws.Name = wsQuelle.Name Then
i = i
Exit For
End If
Next ws
'Einfügung des Tabellenblattes mit den Ergebnissen nach dem Tabellenblatt mit den _
Basisdaten
Worksheets.Add After:=Worksheets(i)
ActiveSheet.Name = strErgebnis
Set wsErgebnis = Worksheets(ActiveSheet.Name)
'Eintragung der Ergebnise in das Tabellenblatt
With wsErgebnis
i = lngBeginn
For Each xkeyErgebnis In dicErgebnis
.Range(strSpalte & i).Value = xkeyErgebnis
i = i + 1
Next xkeyErgebnis
lngEnde = .Range(strSpalte & Rows.Count).End(xlUp).Row
'Autteilung der Ergebnisse auf verschiedene Spalten im neuen Tabellenblatt
.Range(strSpalte & lngBeginn & ":" & strSpalte & lngEnde).Select
Selection.TextToColumns Destination:=Range(strSpalte & lngBeginn), DataType:= _
xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False
.Columns(strSpalte & ":" & strletzteSpalte).AutoFit
End With
End With
Application.ScreenUpdating = True
Set rngBereich = Nothing
Set dicErgebnis = Nothing
Set dicBasis = Nothing
Set wsQuelle = Nothing
Set wsErgebnis = Nothing
End Sub
