Bestimmte Bereiche per VBA kopieren

[Dude85]

Hallo miteinander

In meiner Excel Vorlage gibt es verschiedene Schichten, die der User ausfüllen kann. Editieren kann der User darin nur bestimmte definierte Felder (gesperrt per Makro).

Jede einzelne Schicht setzt sich aus jeweils 2 Zeilen zusammen, und es gibt verbundene Zellen (zum Beispiel E27:G28). Insgesamt können max. 13 Schichten ausgefüllt werden. In Spalte B (nicht editierbar) ist eine vorgegebene Nummerierung der Schichten von -3, -2 und -1. Danach folgen die Schicht-Nr. 1, 2, bis 10. Die erste Schicht (Nr. -3) beginnt in der Zeile 27+28.

Nun zu meiner Frage:
Angenommen der User füllt die Schichten 1 bis 5 ein. Schicht 1 sind Zeilen 33+34, Schicht 2 sind Zeilen 35+36, usw.

Zu einem späteren Zeitpunkt möchte der User beispielsweise zwischen die Schichten 3 und 4 eine neue leere Schicht einführen. Hierzu wäre es praktisch, wenn der User per Button sämtliche Werte (= alle Zellen mit gelber Markierung; ohne H:O und AG:AH!) aus den Schichten 4 und 5 kopieren und diese Werte in die Schicht 5 und 6 fügen kann. Die Zellen der Schicht 4 sind somit wieder leer.

Ist das irgendwie per VBA (Aufruf über eine Schaltfläche) möglich damit der User nicht alle Werte manuell löschen und wieder eintippen muss?

Würde auch der umgekehrte Ablauf funktionieren: Schicht 1 bis 6 ausgefüllt -> Schicht 4 soll gelöscht werden und die Schichten 5 und 6 nach oben kopiert werden?

Besten Dank für die Unterstützung & mfg
Urs (Office Professional Plus 2013, 32bit)

**********

Tabelle1

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

AQ

AR

AS

AT

AU

AV

AW

AX

AY

AZ

BA

BB

BC

BD

BE

BF

BG

BH

BI

BJ

BK

BL

26

Nr.

Tiefe

Bezeichnung

27

-3

-5

28

29

-2

-2

30

31

-1

-1

32

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

[Bamberg]

Hallo Dude,
　
mit verbundenen Zellen ist nicht gut Kirschenessen, aber natürlich ist mit VBA vieles möglich.
In der Anlage schicke ich Dir mal ne Mustermappe mit drei Schaltflächen. Schau Dir doch bitte die mal an.
Was allerdings Dein Blattschutz so anstellt, bleibt noch zu prüfen^^
　
LG Gerd

...mhm ... leider funktioniert aktuell das Hochladen von Dateien nicht :(
Dann mal auf diesem Weg ...

Füge doch mal drei Commandbuttons auf Deinem Tabellenblatt ein:
Commandbutton1 benennst Du "Zeile kopieren"
Commandbutton2 benennst Du "Zeile einfügen"
Commandbutton3 benennst Du "Zeile löschen"

Danach wechselt Du in den VBA Editor und dort in den Codebereich Deiner Tabelle und kopierst Dir folgendes Script:

Code:

Option Explicit

Private MyClipboard As Range
'Hier alle Zelladressen für das Kopieren eintragen
'Bei verbundenen Zellen nur die linke obere Zelladresse angeben
Private Const MusterZelladressen As String = "C27,E27,P27,P28,R27,R28,U27,U28"

Private Sub CommandButton1_Click()
   Call ZellenEinlesen
End Sub

Private Sub CommandButton2_Click()
   Call ZellenSchreiben
End Sub

Private Sub CommandButton3_Click()
   Call ZellenLoeschen
End Sub

Private Sub ZellenEinlesen()

   Dim Zelle As Range
   Dim i As Variant
   
   If TypeName(Selection) = "Range" Then
       i = Selection.Cells(1).Row
       If i Mod 2 = 0 Then i = i - 1
   End If
   
   Set MyClipboard = Nothing
   For Each Zelle In Me.Range(MusterZelladressen)
       If MyClipboard Is Nothing Then
           Set MyClipboard = Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column)
       Else
           Set MyClipboard = Union(Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column), MyClipboard)
       End If
   Next Zelle

End Sub


Private Sub ZellenSchreiben()

   If MyClipboard Is Nothing Then Exit Sub
   
   Dim Zelle As Range
   Dim i As Variant
   
   If TypeName(Selection) = "Range" Then
       i = Selection.Cells(1).Row
       If i Mod 2 = 0 Then i = i - 1
   End If
   
   For Each Zelle In MyClipboard
       Zelle.Parent.Cells(Zelle.Row + (i - MyClipboard.Cells(1).Row), Zelle.Column).Value = Zelle.Value
   Next Zelle

End Sub

Private Sub ZellenLoeschen()

   Dim Zelle As Range
   Dim i As Variant
   
   If TypeName(Selection) = "Range" Then
       i = Selection.Cells(1).Row
       If i Mod 2 = 0 Then i = i - 1
   End If
   
   For Each Zelle In Me.Range(MusterZelladressen)
       Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column).ClearContents
   Next Zelle

End Sub

[snickers]

(falscher Thread)

[Dude85]

Hallo Mr. Bamberg

Ich habe das soeben ausprobiert! Zeile kopieren und einfügen funktioniert super!!! Danke :19: :21:
Beim Löschen gibt es einen Fehler: Laufzeitfehler 1004 mit der Meldung: "Dies ist bei verbundenen Zellen leider nicht möglich."

Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column).ClearContents

Gibt es trotzdem eine Lösung oder mache ich etwas falsch?

Schönen Abend ...und nocheinmal thank u!
Urs

[Kuwer]

Hallo Urs,

Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column).ClearContents

probiere mal so:

Zelle.Parent.Cells(Zelle.Row + (i - Me.Range(MusterZelladressen).Cells(1).Row), Zelle.Column) = ""

Gruß Uwe

[Bamberg]

Hallo Urs,

wie schaut bei Dir diese Zeile hier aus?

Code:

Private Const MusterZelladressen As String = "C27,E27,P27,P28,R27,R28,U27,U28"

LG Gerd

[Dude85]

Lieber Uwe, lieber Gerd

In meinem Testdokument funktioniert das Löschen mit der Ergänzung von Uwe!
Ich versuche nun das ganze im vollständigen Dokument einzubauen.

@ Gerd
Die Zeile sieht wie folgt aus:

Code:

Private Const MusterZelladressen As String = "C27,E27,P27,P28,R27,R28,T27,T28,W27,W28,AB27,AB28,AI27,AI28,AL27,AL28,AO27,AO28,AU27,AU28,AY27,AY28,BA27,BA28,BB27,BB28,BC27,BC28,BD27,BD28,BE27"

Ich danke euch für die super Unterstützung - echt nett
Beste Grüsse - Urs