551 Aufrufe
Gefragt in Tabellenkalkulation von
Hi Forum

Ich suche eine VBA Lösung die folgendes macht.

In Tabelle1 B2 steht eine Zahl z.b 9 diese ist Variable und ändert sich
ständig bei jedem Durchlauf.

In Tabelle 2 sind meine "Archiv Nummern" einige werden mit einem
Makro in .Interior.ColorIndex = 28 eingefärbt.

Jetzt soll nach .Interior.ColorIndex = 28 gesucht werden
wenn unterhalb der gesuchten Farbe
die Zahl aus der Tabelle 1 B2 zb 9 steht dann
kopiere die erste Zahl oberhalb von der Farbe in Tabelle 3

Läst sich das irgendwie machen wäre toll


mfg
Tim2017c

13 Antworten

0 Punkte
Beantwortet von
Hallo Tim2017c .-)

Wie gewünscht!

Gruss Nighty

In diesem Beispiel werden in allen drei Blättern Spalte A genutzt

Sub Suchen()
Dim Zelle As Long
Dim Suche As Object
Dim KDat As Variant
KDat = Worksheets(2).Range("A1:A" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row)
For Zelle = 2 To UBound(KDat)
If KDat(Zelle, 1) = Worksheets(1).Range("A2") Then
If Worksheets(2).Cells(Zelle - 1, 1).Interior.ColorIndex = 28 Then
Worksheets(3).Cells(Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = KDat(Zelle - 2, 1)
End If
End If
Next Zelle
End Sub
0 Punkte
Beantwortet von
Hallo Community ^^

ops ... Dim Suche As Object
kann gelöscht werden,waren noch Altlasten :-)

Gruss Nighty
0 Punkte
Beantwortet von
Hallo Tim2017c .-)

Oder auch so!

Blatt 1 mit unbestimmter Anzahl von Suchbegriffen

Gruss Nighty

Sub Suchen()
Dim ZielZelle As Long, SuchZelle As Long
Dim QuellDat As Variant, SuchDat As Variant
SuchDat = Worksheets(1).Range("A1:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
QuellDat = Worksheets(2).Range("A1:A" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row)
For SuchZelle = 2 To UBound(SuchDat)
For ZielZelle = 2 To UBound(QuellDat)
If QuellDat(ZielZelle, 1) = SuchDat(SuchZelle, 1) Then
If Worksheets(2).Cells(ZielZelle - 1, 1).Interior.ColorIndex = 28 Then
Worksheets(3).Cells(Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = QuellDat(ZielZelle - 2, 1)
End If
End If
Next ZielZelle
Next SuchZelle
End Sub
0 Punkte
Beantwortet von
Hi Nighty

Es läuft nur bedingt

Er müsste mir das ganze Tabellenblatt wo meine eingefärbten Nummern sind durchsuchen.
Ebenfalls wäre es super wenn er das Tabellenblatt 3 dann wieder löscht wenn man das Makro wieder benutzt.

mfg
Tim2017c
0 Punkte
Beantwortet von
Hallo Tim2017c .-)

Dann probier mal das Makro :-)

Gruß Nighty

Sub Suchen()
Dim SuchZelle As Long
Dim QuellDat As Variant, SuchDat As Variant, ZielZelle As Variant
Worksheets(3).Cells.Clear
SuchDat = Worksheets(1).Range("A1:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
Set QuellDat = Worksheets(2).Range(Worksheets(2).Cells(1, 1), Worksheets(2).Cells(22, 2))
For SuchZelle = 2 To UBound(SuchDat)
For Each ZielZelle In QuellDat
If QuellDat(ZielZelle.Row, ZielZelle.Column) = SuchDat(SuchZelle, 1) Then
If Worksheets(2).Cells(ZielZelle.Row - 1, ZielZelle.Column).Interior.ColorIndex = 3 Then
Worksheets(3).Cells(Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = QuellDat(ZielZelle.Row - 2, ZielZelle.Column)
End If
End If
Next ZielZelle
Next SuchZelle
End Sub
0 Punkte
Beantwortet von
Hallo Tim2017c und Community .-)

Korrigiert!

Gruss Nighty

Sub Suchen()
Dim SuchZelle As Long
Dim QuellDat As Variant, SuchDat As Variant, ZielZelle As Variant
Worksheets(3).Cells.Clear
SuchDat = Worksheets(1).Range("A1:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
Set QuellDat = Worksheets(2).Range(Worksheets(2).Cells(1, 1), Worksheets(2).Cells(Worksheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row, Worksheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column))
For SuchZelle = 2 To UBound(SuchDat)
For Each ZielZelle In QuellDat
If QuellDat(ZielZelle.Row, ZielZelle.Column) = SuchDat(SuchZelle, 1) Then
If Worksheets(2).Cells(ZielZelle.Row - 1, ZielZelle.Column).Interior.ColorIndex = 3 Then
Worksheets(3).Cells(Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = QuellDat(ZielZelle.Row - 2, ZielZelle.Column)
End If
End If
Next ZielZelle
Next SuchZelle
End Sub
0 Punkte
Beantwortet von
Hallo Tim2017c .-)

Du musst noch die 3 durch 28 ersetzen (Farbindex)

If Worksheets(2).Cells(ZielZelle.Row - 1, ZielZelle.Column).Interior.ColorIndex = 3 Then


Gruss Nighty
0 Punkte
Beantwortet von
Hi nighty

Es funktioniert zwar aber nicht ganz richtig
wenn du die 16 eingiebst als unter Zahl von der Farbe müsste er die 33 finden
ist aber leider nicht so.

hab die Mappe mal hochgeladen damit du siehst was ich meine
http://www.filehosting.at/file/details/650555/Mappe1.xlsm

Vielen Dank für dein Bemühen
0 Punkte
Beantwortet von
Hallo Tim2017c .-)

Bitte im xls Format(Excel2000),unter saveas erreichbar!

Gruss Nighty
0 Punkte
Beantwortet von
...