Office: (Office 365) VBA dyn. Zellen kopieren und am ende der Liste einfügen

Guten Morgen zusammen,

ich hoffe ihr könnt mir helfen, da ich mich zwar mit Excel auskenne aber mit Makros nichts zu tun habe.

Ich habe folgendes Problem:

Ich möchte einen Zelleneinträge kopieren und die Zellenwerte in eine anderen Tabelle am Ende einfügen.

Der zu kopierende Bereich ist jedoch dynamisch, soll heißen es können mal Einträge von 1 Zeile bis zu 25 Zeilen sein. Die Inhalten sind in den Spalten A bis N aufgeführt. Kopiert werden sollen aber nur die Zeilen mit einem Wert/Text. In allen Zellen a1 bis n25 sind jedoch Formeln, die nicht berücksichtigt werden sollen.

Die Werte sollen dann in einer anderen Liste (anderes Registerblatt) am Ende eingefügt werden, sodass sich dann sukzessive eine Datenbank ergibt. Da diese Tabelle mit jedem Vorgang auch erweitert, ist das ende der Liste somit auch dynamisch.

Leider geht das natürlich nicht über die Makroaufzeichnung.



Ich hoffe ihr könnt mir helfen.



Vielen Dank schon einmal.

 

Hallo,

kopiere folgendes Makro "Kopieren" in ein allgemeines Codemodul (so wie es auch der Makrorekorder getan hätte):

Code:

Option Explicit

Public Sub Kopieren()
  Dim WsQ As Worksheet, WsZ As Worksheet
  Dim rgQ As Range, rgZ As Range
  Dim Zeile1Z As Long
 
  Set WsQ = Worksheets("Quelle")  '<== Quellblatt (anpassen!)
  Set WsZ = Worksheets("Ziel")    '<== Zielblatt  (anpassen!)
 
  'Quellbereich ermitteln:
  Set rgQ = WsQ.Range("A1:N25")
 
  'Zeilennummer der ersten freien Zeile des Zielbereichs ermitteln
  '(Die Spalte A wird dafür überprüft):
  Zeile1Z = WsZ.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
  'Kopiert werden: Werte und Zahlenformate
  rgQ.Copy
  WsZ.Cells(Zeile1Z, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                          Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
  'Kopiermodus beenden
  Application.CutCopyMode = False

End Sub

Die beiden Namen für das Quellblatt und für das Zielblatt müssen an deine Arbeitsblattnamen (=Tabellenregister) angepasst werden. Die Namensvorbesetzung im Makro ist "Quelle" und "Ziel".

Das Makro kann über die Tastenkombination Alt+F8 (Makrodialog) nach Auswahl des Makros "Kopieren" und Drücken des Buttons "Ausführen" aufgerufen werden.

 

Hallo Exl121150

vielen Dank erst einmal für die schnelle Antwort.
Die Funktion geht auch, leider aber nicht so ganz wie ich es mir gewünscht hatte. Leider werden die Daten weiter unten eingetragen und auch alle Zellen kopiert. Es sollen aber nur die Zellen aus der Liste "Übertrag" kopiert werden, bei denen die Formeln Ergebnisse ausgeben. Zellen die Leer sind sollen nicht kopiert werden.
Wahrscheinlich ist das Problem, dass meine Wennfunktion ein "" ausgibt.
Ich habe eine Bsp. Datei mal hochgeladen. Vielleicht erklärt sich dann meine Thematik.

Ich hoffe du kannst mir weiterhelfen.

 

Hallo,

die Probleme aus deinem letzten Posting hätten vermieden werden können, wenn du gleich eine Datei mit Wunschergebnissen hochgeladen hättest.

In der beiliegenden Datei habe ich ein Arbeitsblatt "test(2)" eingefügt, das als testweises Kopierziel der Daten aus "Übertrag!A7:N31" dient. Dabei werden jetzt die sogenannten "Leerzeilen" nicht mehr kopiert.
Sollen andere Arbeitsblätter bzw. Bereiche als Quelle oder Ziel des Kopierens verwendet werden, sind sie wieder zuerst an den gekennzeichneten Stellen im Makro zu ändern.

Code:

Option Explicit

Public Sub Kopieren()
  Dim wsQ As Worksheet, wsZ As Worksheet
  Dim rgQ As Range, rgZeileQ As Range
  Dim ZeileZ As Long

  Set wsQ = Worksheets("Ãœbertrag")  '<== Quellblatt (anpassen!)
  Set wsZ = Worksheets("test(2)")   '<== Zielblatt  (anpassen!)

  'Quellbereich ermitteln:
  Set rgQ = wsQ.Range("A7:N31")     '<== Quellbereich im Quellblatt (anpassen!)

  'Zeilennummer der ersten freien Zeile des Zielbereichs ermitteln
  '(Die Spalte A wird dafür überprüft):
  ZeileZ = wsZ.Cells(Rows.Count, "A").End(xlUp).Row + 1

  'Kopiert werden in nicht leeren Zeilen: Werte und Zahlenformate 
  For Each rgZeileQ In rgQ.Rows
     If Not IstLeerZeile(rgZeileQ) Then
        rgZeileQ.Copy
        wsZ.Cells(ZeileZ, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                               Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ZeileZ = ZeileZ + 1
     End If
  Next rgZeileQ
  'Kopiermodus beenden
  Application.CutCopyMode = False

End Sub
'
'Teste, ob die Zellen im Bereich "rgZeile" alle "leer" sind:
'
Public Function IstLeerZeile(rgZeile As Range) As Boolean
  Dim rgZelle As Range
  Dim vWert As Variant
 
  IstLeerZeile = True
  For Each rgZelle In rgZeile.Cells
     vWert = rgZelle.Value
     If Not IsEmpty(vWert) Then
        Select Case VarType(vWert)
           Case vbString:
                'falls etwas anderes als "" enthalten ist
                If Len(vWert) Then IstLeerZeile = False: Exit Function
           Case vbBoolean:
                'falls WAHR oder FALSCH enthalten ist
                IstLeerZeile = False: Exit Function
           Case Else:
                'falls ein sonstiger numerischer Wert (auch 0) enthalten ist
                IstLeerZeile = False: Exit Function
        End Select
     End If
  Next rgZelle
End Function

Aufgerufen wird das Makro genauso wie in meinem letzten Posting beschrieben.

Mit der ebenfalls enthaltenen Funktion IstLeerZeile(Zellbezug) kann auch in Arbeitsblättern getestet werden, ob es sich beim Zellbereich "Zellbezug" um lauter "Leerzellen" handelt, zB. im Arbeitsblatt "Übertrag":
=IstLeerZeile(A10:N10)
falls das Resultat WAHR ist, handelt es sich um lauter "Leerzellen"; falls die Funktion FALSCH retourniert, ist mindestens 1 Zelle nicht "leer".

 

Guten Morgen Exl121150
vielen vielen Dank für die Unterstützung. Klappt genauso wie angedacht.
Auch die Funktion ISTLeerZeile kannte ich bisher nicht. Aber lernt ja nie aus.

 

Hallo,

diese Funktion gibt es auch normalerweise nicht. Ich habe sie dir im Makro erstellt, wie du an folgender Makrozeile ersehen kannst:
Public Function IstLeerZeile(rgZeile As Range) As Boolean
In den dann folgenden Zeilen bis zur Zeile "End Function" ist sie enthalten.