Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1508to1512
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Werte kopieren

Werte kopieren
17.08.2016 09:40:14
Sigi
Hallo zusammen
Ich habe wiedermal ein Problem mit vba kopieren, bzw. nur Werte erkennen und mitnehmen. Ich habe, gem. angehängtem Excel-Beispiel, eine Datei mit verschiedenen Registern. Die Aufgabe ist, aus allen Registern zwischen "Start" und "Ende" Daten des Bereichs B23:C39; E23:E39; H23:39 in das Zielregister untereinander hinein zu kopieren. Ich habs mit vollgemden Script probiert:
Sub Baukonti()
'löschen von alten Daten
Range("a4:d100").Select
Selection.ClearContents
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'automat.Berechnung ausschalten
Application.Calculation = xlCalculationManual
Sheets("Start").Select
Do
ActiveSheet.Next.Activate
' Blatt merken
Dim strStartBlatt As String
strStartBlatt = ActiveSheet.Name
' kopieren und einfügen
Range("B23:c39").Select
Selection.Copy
Range("A1").Select
Sheets("Baukonti").Select
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' zurück zum Ursprungsregister
ActiveWorkbook.Worksheets(strStartBlatt).Activate
' kopieren und einfügen
Range("e23:e39").Select
Selection.Copy
Range("A1").Select
Sheets("Baukonti").Select
Range("c2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' zurück zum Ursprungsregister
ActiveWorkbook.Worksheets(strStartBlatt).Activate
' kopieren und einfügen
Range("h23:h39").Select
Selection.Copy
Range("A1").Select
Sheets("Baukonti").Select
Range("d2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' zurück zum Ursprungsregister
ActiveWorkbook.Worksheets(strStartBlatt).Activate
Loop Until ActiveSheet.Name = "Ende"
Range("A1").Select
Sheets("Baukonti").Select
Range("A1").Select
'automat.Berechnung einschalten
Application.Calculation = xlCalculationAutomatic
'Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
End Sub
Das Ganze funktioniert wunderbar, bis auf die Spalte H, da hier Formeln hinterlegt sind. Mit "Selection.End(xlDown).Select" geht er eben nicht bis zum letzen Wert sondern bis zum letzten kopierten Bereich. Meine Frage ist nun, wie kann ich entweder nur die Werte beim kopieren erkennen oder wie kann ich "Selection.End(xlDown).Select" umdefinieren, dass er nur bis zum letzten effektiven Wert nach unten geht?
Vielen Dank für eure Hilfe!
Gruss
Sigi
https://www.herber.de/bbs/user/107662.xlsx

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte kopieren
17.08.2016 15:44:16
Michael
Hi Sigi,
ich habe das etwas vereinfacht: kopiert wird aus jedem Blatt alles in einem Rutsch und anschließend werden die überflüssigen Spalten entfernt:
Option Explicit
Sub Baukonti()
Dim Sh As Worksheet, BK As Worksheet
Dim zeile As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set BK = Sheets("Baukonti")
BK.Range("a4:d100").ClearContents
Set Sh = Sheets("Start").Next
Do
Sh.Range("B23:H39").Copy
zeile = BK.Range("A" & BK.Rows.Count).End(xlUp).Row + 1
BK.Range("A" & zeile).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Set Sh = Sh.Next
Loop Until Sh.Name = "Ende"
zeile = BK.Range("A" & BK.Rows.Count).End(xlUp).Row + 1
BK.Range("E4:F" & zeile).Delete Shift:=xlToLeft
BK.Range("C4:C" & zeile).Delete Shift:=xlToLeft
BK.Range("A1").Select
'automat.Berechnung einschalten
Application.Calculation = xlCalculationAutomatic
'Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
End Sub

Außerdem hat Dein Code das Blatt "Ende" mitkopiert - deshalb habe ich das Weiterschalten zum nächsten Blatt nach unten verschoben, das ist die Zeile Set Sh = Sh.Next direkt vor dem Loop.
Schöne Grüße,
Michael
Anzeige
AW: Werte kopieren
17.08.2016 16:15:34
Sigi
Hallo Michael
Vielen Dank, klappt wunderbar!
Gruss
Sigi
freut mich, danke für die Rückmeldung,
17.08.2016 17:36:33
Michael
Sigi,
schöne Grüße zurück,
Michael

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige