AW: Zeilen in neues Tabellenblatt kopieren & sortieren
04.01.2013 15:05:53
fcs
Hallo Julia,
hier mal 2 Makros, die die Daten aus "Einkauf" nach "aktuell" bzw. "GWG" übertragen.
Gruß
Franz
Sub kopieren_aktuell()
Dim wksEK As Worksheet, ZeileEK As Long, SpalteEK As Long
Dim wksZiel As Worksheet, Zeile_Z As Long, Spalte_Z As Long
Dim SpaltePruef As Long
Set wksEK = ActiveWorkbook.Worksheets("Einkauf")
SpaltePruef = wksEK.Range("K1").Column 'Spalte, die auf "x" geprüft werden soll
Set wksZiel = ActiveWorkbook.Worksheets("aktuell")
Application.ScreenUpdating = False
'Alte Daten im Zielblatt löschen
With wksZiel
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_Z > 1 Then
.Range(.Rows(2), .Rows(Zeile_Z)).Delete
End If
End With
Zeile_Z = 1
With wksEK
For ZeileEK = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If LCase(.Cells(ZeileEK, SpaltePruef).Value) = "x" Then
Zeile_Z = Zeile_Z + 1
For SpalteEK = 1 To 7
'Spalte in Zieltabelle setzen für Werte in Tabelle Einkauf
'Spalte_Z = 0 setzen für Spalten, die nicht übertragen werden sollen
Select Case SpalteEK
Case 1: Spalte_Z = 0 'Bestelldatum
Case 2: Spalte_Z = 2 'Unternehmen
Case 3: Spalte_Z = 3 'Artikel
Case 4: Spalte_Z = 4 'Preis
Case 5: Spalte_Z = 5 'Nr
Case 6: Spalte_Z = 6 'Konto
Case 7: Spalte_Z = 1 'Standort
End Select
If Spalte_Z > 0 Then
wksZiel.Cells(Zeile_Z, Spalte_Z).Value = .Cells(ZeileEK, SpalteEK).Value
End If
Next
End If
Next
End With
If Zeile_Z > 1 Then
With wksZiel
If Zeile_Z > 2 Then
'Daten sortieren
With .Range(.Cells(1, 1), .Cells(Zeile_Z, 6))
.Sort key1:=.Range("A1"), order1:=xlAscending, _
Key2:=.Range("B1"), order2:=xlAscending, _
Key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
End With
End If
'Leerzeilen und Spaltentitel einfügen für Werte in Spalte A
For Zeile_Z = Zeile_Z To 2 Step -1
If .Cells(Zeile_Z - 1, 1).Value .Cells(Zeile_Z, 1).Value Then
.Rows(Zeile_Z).Insert
.Cells(Zeile_Z, 1) = .Cells(Zeile_Z + 1, 1)
With .Range(.Cells(Zeile_Z, 1), .Cells(Zeile_Z, 6))
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = 10092543 'hellgelb
End With
If Zeile_Z > 2 Then
.Rows(Zeile_Z).Insert
End If
End If
Next
End With
End If
Application.ScreenUpdating = True
End Sub
Sub kopieren_GWG()
Dim wksEK As Worksheet, ZeileEK As Long, SpalteEK As Long
Dim wksZiel As Worksheet, Zeile_Z As Long, Spalte_Z As Long
Dim SpaltePruef As Long
Set wksEK = ActiveWorkbook.Worksheets("Einkauf")
SpaltePruef = wksEK.Range("N1").Column 'Spalte, die auf "x" geprüft werden soll
Set wksZiel = ActiveWorkbook.Worksheets("GWG")
Application.ScreenUpdating = False
'Alte Daten im Zielblatt löschen
With wksZiel
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_Z > 1 Then
.Range(.Rows(2), .Rows(Zeile_Z)).Delete
End If
End With
Zeile_Z = 1
With wksEK
For ZeileEK = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If LCase(.Cells(ZeileEK, SpaltePruef).Value) = "x" Then
Zeile_Z = Zeile_Z + 1
For SpalteEK = 1 To 7
'Spalte in Zieltabelle setzen für Werte in Tabelle Einkauf
'Spalte_Z = 0 setzen für Spalten, die nicht übertragen werden sollen
Select Case SpalteEK
Case 1: Spalte_Z = 0 'Bestelldatum
Case 2: Spalte_Z = 1 'Unternehmen
Case 3: Spalte_Z = 2 'Artikel
Case 4: Spalte_Z = 3 'Preis
Case 5: Spalte_Z = 4 'Nr
Case 6: Spalte_Z = 5 'Konto
Case 7: Spalte_Z = 0 'Standort
End Select
If Spalte_Z > 0 Then
wksZiel.Cells(Zeile_Z, Spalte_Z).Value = .Cells(ZeileEK, SpalteEK).Value
End If
Next
End If
Next
End With
If Zeile_Z > 1 Then
With wksZiel
If Zeile_Z > 2 Then
'Daten sortieren
With .Range(.Cells(1, 1), .Cells(Zeile_Z, 6))
.Sort key1:=.Range("A1"), order1:=xlAscending, _
Key2:=.Range("B1"), order2:=xlAscending, Header:=xlYes
End With
End If
'Leerzeilen und Spaltentitel einfügen für Werte in Spalte A
For Zeile_Z = Zeile_Z To 2 Step -1
If .Cells(Zeile_Z - 1, 1).Value .Cells(Zeile_Z, 1).Value Then
.Rows(Zeile_Z).Insert
.Cells(Zeile_Z, 1) = .Cells(Zeile_Z + 1, 1)
With .Range(.Cells(Zeile_Z, 1), .Cells(Zeile_Z, 6))
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = 10092543 'hellgelb
End With
If Zeile_Z > 2 Then
.Rows(Zeile_Z).Insert
End If
End If
Next
End With
End If
Application.ScreenUpdating = True
End Sub