Office: (Office 2010) Kopieren von Tabelle1 in Tabelle2

Hallo Freunde,

folgendes Anliegen:

Ich habe im Arbeitsblatt Tabelle1 eine Tabelle, in die Werte eingegeben werden. Nun möchte ich diese Werte per Makro, in eine andere Tabelle im Arbeitsblatt Tabelle2 kopieren - nämlich immer an das Ende bzw. in die nächst freie Zeile dieser Tabelle. Diese soll sich "unendlich" fortsetzen.

Vielen Dank im Voraus!

MfG

roger

 

In einem anderen Forum habe ich folgendes gefunden:

Code:

Option Explicit

Public Sub Kopieren()

Dim WkSh_Q  As Worksheet
Dim WkSh_Z  As Worksheet

   Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle1")
   Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2")
   
   WkSh_Q.Range("A1:D1").Copy
   WkSh_Z.Range("A" & WkSh_Z.Cells(WkSh_Z.Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial _
   Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False

End Sub	

Ich habe bereits versucht, den Code für meine Zwecke zu bearbeiten, aber bin kläglich daran gescheitert.

Die Werte in den Zellen A4, C6, E6 und H6 aus Tabelle1 sollen in die nächste freie Zeile der Spalten A, B, C und D in Tabelle2 kopiert werden.
Also A4 in Spalte A, C6 in Spalte B, E6 in Spalte C und H6 in Spalte D.

Über Hilfe wäre ich sehr dankbar!

MfG

roger

 

Ich bin etwas vorangekommen. Das Macro funktioniert soweit, jedoch versetzt sich nach jedem Eintrag der nächste Eintrag um eine Zeile (da nach jedem copy&paste eine erneute Prüfung erfolgt.

Wie schaffe ich es nun, dass alle Werte korrekt in die letzte freie Zeile kopiert werden?

Code:

Sub CopyTest()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet

Set copySheet = Worksheets("Tabelle1)
Set pasteSheet = Worksheets("Tabelle2")

copySheet.Range("A4").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
copySheet.Range("C6").Copy
pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
copySheet.Range("E6").Copy
pasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
copySheet.Range("H6").Copy
pasteSheet.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

Hallo,

das kann ich nicht bestätigen, gemäß meinen Tests hat es funktioniert - abgesehen von einigen Ungereimtheiten:
1) in der Zeile mit Worksheets("Tabelle1) fehlt das 2. Anführungszeichen
2) in den Zeilen pasteSheet.Cells(Rows.Count, .... steht vor Rows keine Objektangabe, was bewirkt, dass defaultmäßig das ActiveSheet verwendet wird, sodass diese Zeilen eigentlich pasteSheet.Cells(ActiveSheet.Rows.Count, .... lauten.

Da im pasteSheet für alle 4 Pastes dieselbe Zeile verwendet wird, habe ich das Makro etwas vereinfacht:

Code:

Sub CopyTest()
  Dim copySheet As Worksheet
  Dim pasteSheet As Worksheet
  Dim Zeile As Long
  
  Set copySheet = Worksheets("Tabelle1")
  Set pasteSheet = Worksheets("Tabelle2")
  
  With pasteSheet
    Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
  End With
  
  copySheet.Range("A4").Copy
  pasteSheet.Cells(Zeile, 1).PasteSpecial xlPasteValues
  copySheet.Range("C6").Copy
  pasteSheet.Cells(Zeile, 2).PasteSpecial xlPasteValues
  copySheet.Range("E6").Copy
  pasteSheet.Cells(Zeile, 3).PasteSpecial xlPasteValues
  copySheet.Range("H6").Copy
  pasteSheet.Cells(Zeile, 4).PasteSpecial xlPasteValues
  
  Application.CutCopyMode = False
End Sub

 

Und ein weiteres Mal vielen vielen Dank an dich =)

Bist mein Excel Held!