Loop Copy Paste

Bild

Betrifft: Loop Copy Paste
von: Ani
Geschrieben am: 09.09.2015 16:43:53

Hallo,
ich habe ein Excel mit mehreren, identisch aufgebauten Blättern. In diese machen die User Eingaben. Die Eingaben würde ich gerne per VBA in ein neues Excel konsolidieren, also untereinander schreiben. Ein neues Excel zu erstellen und zu speichern ist gelungen aber den Loop mit dem Kopieren und in der nächsten freien Zeile einfügen klappt leider nicht. Kann jemand helfen?
Danke und Gruss
Ani

Bild

Betrifft: AW: Loop Copy Paste - Tabellen konsolidieren
von: fcs
Geschrieben am: 13.09.2015 20:01:25
Hallo Ani,
mit etwas Einsatz hättest du hier im Archiv sicher auch etwas passendes gefunden.
Nachfolgend ein entsprechendes Makro.
Gruß
Franz

Sub DatenKonsolidieren()
    Dim wkbQ As Workbook
    Dim wksQ As Worksheet
    Dim ZeileQ As Long, ZeileQ1 As Long
    Dim ZeileZ As Long
    Dim StatusCalc As Long
    Dim wksZ As Worksheet
    
    Set wkbQ = ActiveWorkbook 'Arbeitsmappe mit den Tabellen, die konsolidiert _
                werden sollen
    ZeileQ1 = 2 '1. Zeile in Quellblättern mit Daten, die kopiert werden sollen _
                = Zeile unterhalb der Spaltentitel
    'Makrobremsen lösen
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        StatusCalc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    For Each wksQ In wkbQ.Worksheets
        Select Case wksQ.Name
            Case "TabXYZ", "Tab123"
                'diese Blätter nicht mit konsolidieren - Namen ggf. anpassen
            Case Else
                If wksZ Is Nothing Then
                    '1. Tabellenblatt komplett in neue Mappe kopieren
                    wksQ.Copy
                    Set wksZ = ActiveSheet
                    wksZ.Name = "AlleDaten"
                Else
                    With wksQ
                        'letzte benutzte Zeile im Quelltabellenblatt
                        With .UsedRange
                            ZeileQ = .Row + .Rows.Count - 1
                        End With
                        If ZeileQ >= ZeileQ1 Then
                            'Daten kopieren
                            .Range(.Rows(ZeileQ1), _
                                   .Rows(ZeileQ)).Copy wksZ.Cells(ZeileZ, 1)
                        End If
                    End With
                    
                End If
                'nächste freie Zeile im Zieltabellenblatt
                With wksZ.UsedRange
                    ZeileZ = .Row + .Rows.Count
                End With
        End Select
    Next
    
    'Formeln im Zielblatt durch Werte ersetzen
    With wksZ.UsedRange
        .Calculate
        .Value = .Value
    End With
    'Makrobremsen zurücksetzen
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = StatusCalc
    End With
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zellergebnis ausgeben bei mehreren Suchergebenisse"