Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA copy paste

VBA copy paste
06.07.2018 09:09:36
Josi
Hallo zusammen
Ich habe eine Excelmappe mit ca 30 Tabellen in der Namen stehen (zum teil farblich markiert) Im Beispiel die Tabellen A B C
https://www.herber.de/bbs/user/122503.xlsx
Nun möchte ich den Auswertung zuerst die farbigen Namen und dann die schwarzen Namen und das ganze ohne Leerzeilen.
Im voraus schon vielen Dank für eure Hilfe
Josi

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Autofilter
06.07.2018 09:42:39
Fennek
Hallo Stefan,
mit VBA kann man nacheinander alle Farbern einzeln auswählen und dann kopieren.
mfg
AW: VBA copy paste
06.07.2018 09:47:26
UweD
Hallo
per VBA...
Option Explicit

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 ZielTB.Cells(NeuZeile, Sp)
                
            End If
        End If
    Next
    
    '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
Anzeige
AW: VBA copy paste
06.07.2018 10:36:14
Josi
Hallo vielen dank für die Formel.
Nur habe ich nicht bedacht das in den Quelltabellen Formeln stehen die beim kopieren dann nicht mehr stimmen.
Es sollten also nur Werte kopiert werden.
Kannst du mir nochmal helfen?
Josi
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
Anzeige
AW: VBA copy paste
06.07.2018 12:30:53
Josi
Alles klar
Danke
jetzt klappts
Prima! Danke für die Rückmeldung. owT
06.07.2018 12:39:08
UweD

319 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige