AW: Wert suchen und Bereich in gefundener Zeile kop.
23.01.2011 09:06:06
fcs
Hallo Marc,
hier ein Beispielmakro, das du bzgl. der Tabellennamen und Konstanten noch anpassen muss.
Gruß
Franz
Sub KW_Daten_Uebertragen()
Dim wksDaten As Worksheet, wksEingabe As Worksheet, wksZiel As Worksheet
Dim ZeileDaten As Long, ZeileZiel As Long, Spalte As Long
Dim vSuchen
Const ZelleKW As String = "C5" 'Eingabezelle für zu suchende KW
Const SpalteZiel As Long = 1 'EinfügeSpalte in Zieltabelle
Const ZeileZiel1 As Long = 4 'Zeile in der Einfügen beginnen soll wenn _
noch keine Daten vorhanden
Set wksDaten = Worksheets("Daten") 'Blatt in dem alle KW-Daten stehen
Set wksEingabe = Worksheets("Eingabe") 'Blatt in dem die zu suchende KW eingegeben wird
Set wksZiel = Worksheets("Ziel") 'Blatt in das Daten der KW kopiert werden sollen
'zu suchende KW einlesen
vSuchen = wksEingabe.Range(ZelleKW).Value
'1. Zielzeile ermitteln
With wksZiel
ZeileZiel = ZeileZiel1
For Spalte = SpalteZiel To SpalteZiel + 3
ZeileZiel = Application.WorksheetFunction.Max(ZeileZiel, _
.Cells(.Rows.Count, Spalte).End(xlUp).Row + 1)
Next
End With
'KW in Datentabelle suchen
With wksDaten
Application.ScreenUpdating = False
For ZeileDaten = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(ZeileDaten, 2).Value = vSuchen Then
'Zellen aus Spalten C:F kopieren
.Range(.Cells(ZeileDaten, 3), .Cells(ZeileDaten, 6)).Copy _
Destination:=wksZiel.Cells(ZeileZiel, SpalteZiel)
ZeileZiel = ZeileZiel + 1
End If
Next
Application.ScreenUpdating = True
End With
End Sub