AW: Blatt Filtern B Spalte und Zeileninhalt zusamm
30.04.2008 19:39:00
helena
habe folgenden Code gefunden und angepasst, habe aber noch das Problem er schreibt mir in anderes BLATT i.O aber er Listet ZELLINHALT FARBE immer noch pro NAMESEINTRAG d.h. wenn "AA" 10 Einträge hat schreibt er alles auch in 10 Zeilen statt in nur eine, ... nächste Name wieder nur in eine ... usw.
Global nam, t, s
Sub daten_uebertragen_all()
Application.ScreenUpdating = False
Dim nam(50, 400), tabe(1), dat(3, 400, 255) ' Felder dimensionieren
Dim vonam(50, 100), pers(50, 100) ' Felder dimensionieren
tabe(1) = "1_Semester" ' Namen der Tabellenblätter
t = 13 ' Startwert für Datenübertrag (Zeile 13)
' Inhalte einlesen
For u = 1 To 1 ' Aufruf Tabellenblatt
Worksheets(tabe(u)).Activate ' Tabellenblatt aktivieren
For s = 13 To 399 ' Lesebereich (Zeile 13 bis Zeile 50) bei _
bedarf vergrößern
If Len(Cells(s, 1)) > 0 Then ' wenn Pers.Nr dann...
'pers(u, s) = Cells(s, 1) ' ... Personalnummer einlesen
nam(u, s) = Cells(s, 5) ' ... Name einlesen
'vonam(u, s) = Cells(s, 3) ' ... Vorname einlesen
For sp = 4 To 255 ' Start Schleife zum Einlesen der Farben
dat(u, s, sp) = Cells(s, sp).Interior.ColorIndex ' Farbnummern einlesen
Next sp
End If
Next s
Next u
Worksheets("alle Mo+IBS").Activate ' Tabellenblatt aktivieren
Range("A13:C300").Select 'Bereiche zum löschen aktivieren
Selection.ClearContents
Range("D13:IV300").Select
Application.Run "Trendsys08_V5.xls!Löschen" ' starte Macro löschen
Range("A13").Select
b = 0
For u = 1 To 1 ' Tabelle 1-3 (tabe 1-3)
For s = 13 To 399 ' von Zeile 13 bis 50
Do While Cells(s + b, 1) "" ' gefüllte Zellen finden
b = b + 1 ' Schleifenzähler
Loop
'Cells(s + b, 1) = pers(u, s) ' Personalnummer in Tabelle schreiben
Cells(s + b, 2) = nam(u, s) ' Namen in Tabelle schreiben
'Cells(s + b, 3) = vonam(u, s) ' Vornamen in Tabelle schreiben
'For sp = 4 To 255
'If dat(u, s, sp) 4 Then GoTo sprung ' wenn Farbe rot oder grün. _
'Cells(s + b, sp).Interior.ColorIndex = dat(u, s, sp) ' ...Farben übertragen _
sprung:
For sp = 4 To 255
If dat(u, s, sp) = 3 Or dat(u, s, sp) = 5 Or dat(u, s, sp) = 6 Or dat(u, s, sp) = 7 Or _
dat(u, s, sp) = 16 Or dat(u, s, sp) = 34 Or dat(u, s, sp) = 41 Or dat(u, s, sp) = 48 Then
' wenn Farbe rot oder grün...
Cells(s + b, sp).Interior.ColorIndex = dat(u, s, sp) ' ...Farben ü _
bertragen
End If
Next sp
Next s
Next u
Application.ScreenUpdating = True
End Sub
DANKE
gruss helena