AW: VBA Kopieren mit Wert und Format
20.06.2018 14:57:11
fcs
Hallo Partrik,
die 6 verbundenen Zellbereiche befinden sich im Zellbereich J3:N5.
Das macht es etwas komplizierter.
Hier müssen die Zellbereiche J3:K5, L3:N5, und J6:N49 getrennt übertragen werden, damit kein Fehler auftritt.
Sub KW_Abschluß_Klicken()
Dim Zeile As Long, Spalte As Long
Dim wksWo As Worksheet
Dim wksJahr As Worksheet
'Message Box generieren
If MsgBox("KW abschließen & zurücksetzen? TEST TEST", _
vbOKCancel) = vbCancel Then
Exit Sub
End If
Set wksWo = Sheets("Wochenbericht")
Set wksJahr = Sheets("Jahresübersicht")
Application.ScreenUpdating = False
With wksJahr
'erste freie Zeile in Ausgabe-Blatt in Übersicht
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Bereich 1 kopieren
wksWo.Range("A3:I49").Copy
'einfügen in
Spalte = .Range("A3").Column
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Bereich 2 kopieren = 1. Spalten-Bereich mit verbundenen Zellen
wksWo.Range("J3:K5").Copy
'einfügen in
Spalte = .Range("J3").Column
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Bereich 3 kopieren = 1. Spalten-Bereich mit verbundenen Zellen
wksWo.Range("L3:N5").Copy
'einfügen in
Spalte = .Range("L3").Column
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Bereich 5 kopieren
wksWo.Range("J6:N49").Copy
'einfügen in
Spalte = .Range("J6").Column
.Cells(Zeile + 3, Spalte).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Zeile + 3, Spalte).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Bereich 6 kopieren
wksWo.Range("O3:AO49").Copy
'einfügen in
Spalte = .Range("O3").Column
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Zeile, Spalte).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Kopiermodus beenden
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Hilfsmakro zur Suche von verbundenen Zellbereichen
Sub verbundene_Zellensuchen()
Dim wks As Worksheet
Dim rngZelle As Range
Set wks = ActiveSheet
For Each rngZelle In wks.UsedRange.Cells
If rngZelle.MergeCells = True Then
If MsgBox("Verbunden: " & rngZelle.MergeArea.Address(False, False, xlA1), _
vbOKCancel, "verbundene Zellen suchen") = vbCancel Then Exit For
End If
Next
End Sub