AW: Suchen nach mehreren Werten
25.01.2015 10:24:30
fcs
Hallo Olaf,
nachfolgend dein Makro entsprechend angepasst/ergänzt - aber ungetestet.
Ich hab es aber so gelöst, dass nicht kopiert wird, sondern die Werte einfach übertragen werden.
Falls die Datei "Fehlzei.xls" nicht zwingend schon geöffnet ist, dann muss in dem Makro noch eine entsprechende Prüfung eingebaut und ggf. die Datei geöfnet werden.
Gruß
Franz
Sub test()
Dim Spalte_Z, zeile As Long
Dim wksAktiv As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet, Zeile_Z As Long
Dim StatusCalc As Long
Set wksAktiv = ActiveSheet
Set wkbZiel = Application.Workbooks("Fehlzeit.xls") 'Datei muss bereits geöfnet sein!!
Set wksZiel = wkbZiel.Worksheets(1) 'Nr. oder Name in Anführungszeichen ggf. anpassen
With wksZiel
'letzte ausgefüllte Zeile in Spalte G
Zeile_Z = .Cells(.Rows.Count, 7).End(xlUp).Row
End With
Spalte_Z = 15 'für Spalte D als test
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
With wksAktiv
For zeile = 7 To .Cells(.Rows.Count, Spalte_Z).End(xlUp).Row
Select Case .Cells(zeile, Spalte_Z)
Case "TU", "SU", "FS", "LK", "LK", "LU", "KO", "LE", "KOL"
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, 7) = .Cells(zeile, 1) 'A --> G
wksZiel.Cells(Zeile_Z, 6) = .Cells(zeile, 2) 'B --> F
wksZiel.Cells(Zeile_Z, 11) = 502 'Zahl --> K
Case Else
'do nothing
End Select
Next
End With
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
.EnableEvents = True
End With
Set wkbZiel = Nothing: Set wksZiel = Nothing: Set wksAktiv = Nothing
End Sub