AW: Daten filtern, kopieren und inneue Tabelle einfüge
17.06.2010 17:29:17
fcs
Hallo Luan,
hier mal ein Makro-Ansatz.
Die Code - Nummerierung funktioniert nur wenn die erste Zeile der gefilterten Daten die Posten-Zeile ist.
Die 3 Sprachen erhalten dabei immer die gleiche Code-Nummer, wenn kein Filter für eine Sprache gesetzt wurde.
Gruß
Franz
Sub FilterDaten_nach_Arbeitsplan()
Dim wksPlan As Worksheet, wksGrund As Worksheet
Dim SpaltePosten As Long, SpalteSprache As Long, Zeile_L As Long, Zeile As Long
Dim oFilter As Filter, iIndex As Long
Dim CodeGrau As Long, CodeGold As Long, lStep As Long
Const Zeile_1_Plan = 1 'Zeile mit Filter-Titel
Const Zeile_1_Grund = 3 'Zeile mit Filter-Titel
Const lGrau As Long = 12632256, lGold As Long = 52479 'Farbwerte für Grau und Gold
If MsgBox("Gefilterte Daten in den Arbeitsplan übertragen", vbQuestion + vbYesNo, _
"Gefilterte Daten --> Arbeitsplan") = vbYes Then
Set wksPlan = Worksheets("Arbeitsplan")
Set wksGrund = Worksheets("Grunddaten")
With wksGrund
'Prüfen welche Filter gesetzt
iIndex = 0
For Each oFilter In .AutoFilter.Filters
iIndex = iIndex + 1
If oFilter.On = True Then
Select Case iIndex
Case 1 To 3
SpalteSprache = iIndex
Case 4 To 18
SpaltePosten = iIndex
Case Else
'do nothing
End Select
End If
Next
End With
If SpaltePosten = 0 Then
MsgBox "Es wurde kein Filter im Bereich der Posten gesetzt. Makro wird abgebrochen", _
vbInformation + vbOKOnly, "Gefilterte Daten --> Arbeitsplan"
Exit Sub
End If
With wksPlan
'Altdaten im Plan löschen
If .Cells.SpecialCells(xlCellTypeLastCell).Row > Zeile_1_Plan Then
.Range(.Rows(Zeile_1_Plan + 1), .Rows(.Cells.SpecialCells(xlCellTypeLastCell).Row)). _
Delete
End If
End With
With wksGrund
'letzte sichtbare Datenzeile
Zeile_L = .Cells(.Rows.Count, SpaltePosten).End(xlUp).Row
'Name Posten übertragen
.Cells(Zeile_1_Grund, SpaltePosten).Copy Destination:=wksPlan.Cells(Zeile_1_Plan, 4)
'Spalte mit Sprachen-Kreuzchen übertragen
.Range(.Cells(Zeile_1_Grund + 1, 1), .Cells(Zeile_L, 3)).Copy _
Destination:=wksPlan.Cells(Zeile_1_Plan + 1, 1)
'Spalte mit Postenfilter übertragen
.Range(.Cells(Zeile_1_Grund + 1, SpaltePosten), .Cells(Zeile_L, SpaltePosten)).Copy _
Destination:=wksPlan.Cells(Zeile_1_Plan + 1, 4)
'Spalten V bis AM mit Daten übertragen
.Range(.Cells(Zeile_1_Grund + 1, 22), .Cells(Zeile_L, 39)).Copy _
Destination:=wksPlan.Cells(Zeile_1_Plan + 1, 5)
End With
With wksPlan
'Codes generieren
If SpalteSprache 0 Then
lStep = 1 'Filter für eine der Sprachen wurde gesetzt
Else
lStep = 3 'kein Filter für eine der Sprachen wurde gesetzt
End If
CodeGrau = .Cells(Zeile_1_Plan + 1 + lStep, 5) 'Basis Code für Posten auslesen aus _
Postenzeile
For Zeile = Zeile_1_Plan + 1 + lStep + lStep To .Cells(.Rows.Count, 4).End(xlUp).Row Step _
lStep
If .Cells(Zeile, 5).Interior.Color = lGrau Then
CodeGrau = CodeGrau + 10
CodeGold = CodeGrau
.Range(.Cells(Zeile, 5), .Cells(Zeile + lStep - 1, 5)) = CodeGrau
ElseIf .Cells(Zeile, 5).Interior.Color = lGold Then
CodeGold = CodeGold + 1
.Range(.Cells(Zeile, 5), .Cells(Zeile + lStep - 1, 5)) = CodeGold
End If
Next
End With
End If
End Sub