AW: Auslesen von Mitarbeitern und Kopieren in neue
19.05.2007 01:51:00
Mitarbeitern
Hallo Michael,
wenn das WAHR dann auch jeweils in einer Zelle steht, dann geht es mit folgendem Makro. Tabellennamen, Spaltennummern und Startzeilennummern muss du natürlich noch anpassen.
Gruß
Franz
Sub NamenAuslesen()
Dim wksListe As Worksheet, wksMitarbeiter As Worksheet
Dim ZeileListe As Long, ´Reihe As Long
Set wksListe = Worksheets("Liste") 'Tabelle in die Mitarbeiter kopiert werden sollen
ZeileListe = 2 'Zeile ab der Mitarbeiter eingetragen werdne sollen
'Alte Daten in Liste löschen
With wksListe
.Range(.Rows(ZeileListe), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).ClearContents
End With
For Each wksMitarbeiter In ActiveWorkbook.Worksheets
Select Case wksMitarbeiter.Name
Case "Liste", "Tabelle3" 'Liste der Tabellennamne, die keine Mitarbeiter enthalten
'do nothing
Case Else
With wksMitarbeiter
'2 in nächter Zeile ist die Reihe ab der in Mitarbeiter-tabellen ausgelesen werden soll
For Reihe = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Überprüfung der Spalten 4, 5 und 6 auf WAHR (False)
If .Cells(Reihe, 4).Value = True Or .Cells(Reihe, 5).Value = True _
Or .Cells(Reihe, 6).Value = True Then
wksListe.Cells(ZeileListe, 1).Value = .Cells(Reihe, 1) 'Name
wksListe.Cells(ZeileListe, 2).Value = .Cells(Reihe, 2) 'Vorname
ZeileListe = ZeileListe + 1
End If
Next
End With
End Select
Next
End Sub