AW: VBA copy paste
06.07.2018 11:29:17
UweD
Hallo nochmal
dann so
Sub FarbCopy()
Dim Tb As Worksheet, LR As Long, ZielTB As Worksheet, NeuZeile As Long
Dim AbZeile As Integer, Sp As Integer
'*** Ggf. anpassen
AbZeile = 5
Sp = 2 'Spalte B
Set ZielTB = Sheets("Auswertung")
'***
'reset
ZielTB.Columns(Sp).Delete
For Each Tb In ThisWorkbook.Worksheets
If Tb.Name <> ZielTB.Name Then
If WorksheetFunction.CountA(Tb.Columns(Sp)) > 0 Then 'Nur wenn Daten vorhanden sind
LR = Tb.Cells(Tb.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
'erste Freie Zeile finden
NeuZeile = ZielTB.Cells(ZielTB.Rows.Count, Sp).End(xlUp).Row + 1
NeuZeile = WorksheetFunction.Max(AbZeile, NeuZeile)
'kopieren
Tb.Cells(AbZeile, Sp).Resize(LR - AbZeile + 1, 1).Copy
With ZielTB.Cells(NeuZeile, Sp)
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Werte kopieren
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False 'Formate kopieren
End With
End If
End If
Next
Application.CutCopyMode = False
'Nach Farben sortieren
With ZielTB.Sort
.SortFields.Clear
.SortFields.Add(Columns(Sp), xlSortOnFontColor, xlAscending, , xlSortNormal) _
.SortOnValue.Color = RGB(255, 0, 0) 'rot
.SortFields.Add(Columns(Sp), xlSortOnFontColor, xlAscending, , xlSortNormal) _
.SortOnValue.Color = RGB(0, 176, 80) 'grün
.SortFields.Add(Columns(Sp), xlSortOnFontColor, xlAscending, , xlSortNormal) _
.SortOnValue.Color = RGB(0, 0, 0) 'ohne
.SetRange Cells(AbZeile, Sp).Resize(NeuZeile + LR - AbZeile, Sp)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
LG UweD