AW: Nach Wersten suchen und ganze Zeile kopieren!
12.09.2014 20:10:24
Adis
Hallo
hier eine Makro Lösung die m.E. ohne Spezialfilter auskommt, aber effektiv ist.
Es würde mich freuen wenn sie laeuft. Bitte in ein normales Modulblatt kopieren.
Zuerst in einer Testdatei testen ob alles funktioniert wie gewünscht, damit nicht
versehentlich Daten in der Originaldatei zerstört werden.
Die erste Version sieht vor über drei Zellen Werte einzugeben, die gesucht werden.
Bei mir in der Tabelle1, die Original Tabelle mit allen Obstsorten in die Zellen:
Sorte = Range("G2"), Farbe = Range("H2"), Datum = Range("I2")
Über einen Button sucht er die Werte und kopiert fortlaufend in Tabelle2
Als alter Praktiker, der selbst auf dem Grossmarkt gearbeitet hat, ist mir das
viel zu umstaendlich. Viel schneller ist mein -Automatisch ausfüllen- Programm!
Hier gibt man in eine Hilfsspalte ("E") einen Wert ein, egal was, Buchstabe "a"
und das Programm kopiert automatisch alle markierten Zeilen in Tabelle 2.
Bitt mal ausprobieren ob mir als altem Praktiker eine gute Lösung gelungen ist.
Const Adr1 = "A2" 'Anfangs Adresse (ohne Überschrift) für Obst in Tabelle1
Const KopSpa = 3 'Anzahl zu kopierende Spalten, erweiterbar für Stückzahl, etc.
Const AutoSp = "E" 'Hilfsspalte eingeben (hier D) für Auto Ausfüllen
Dim Tab1 As Object, Tab2 As Object
Dim Sorte, Farbe, Datum 'Variant
Sub Obst_Manuell_Suchen_Kopieren()
Set Tab1 = Sheets("Tabelle1")
Set Tab2 = Sheets("Tabelle2")
Sheets("Tabelle1").Select
Sorte = Range("G2").Value
Farbe = Range("H2").Value
Datum = Range("I2").Value
'Schleife zum durchsuchen von Tabelle1
For Each i In Range(Adr1, Range(Adr1).End(xlDown))
If i.Value = Sorte Then
If i.Cells(1, 2) = Farbe Then
If i.Cells(1, 3) = Datum Then
'** Select nur zum Spalten Test
'i.Resize(1, Spa).Select: Exit Sub
'zuerst End Zeile in Tabelle 2 finden
If Tab2.Range("A2").Value = Empty Then Edr = "A2" Else _
Edr = Tab2.Range("A1").End(xlDown).Offset(1, 0).Address
'gefundene Zeile -mit Formate- in Tabelle2 kopieren
i.Resize(1, KopSpa).Copy Tab2.Range(Edr)
End If
End If
End If
Next i
End Sub
Sub ObstListe_automatisch_erstellen()
Set Tab1 = Sheets("Tabelle1")
Set Tab2 = Sheets("Tabelle2")
Sheets("Tabelle1").Select
If Tab2.Range("A2").Value = Empty Then Z = 2 Else _
Z = Tab2.Range("A1").End(xlDown).Row + 1
'Schleife zum durchsuchen von Tabelle1
For Each i In Range(Adr1, Range(Adr1).End(xlDown))
'ausgewertet wird ob Spalte D leer ist oder nicht
If i.Cells(1, AutoSp) "" Then
'gefundene Zeile -mit Formate- in Tabelle2 kopieren
i.Resize(1, KopSpa).Copy Tab2.Range("A1").Cells(Z, 1)
Z = Z + 1
End If
Next i
End Sub
Gruss Adis