Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1868to1872
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

Format und Werte in Sheet kopieren

Format und Werte in Sheet kopieren
31.01.2022 13:26:54
Björn
Guten Tag,
mein VBA Code tut soweit, was er soll er kopiert einen Zellbereich aus dem ersten Sheet in zwei andere. Bei einem Sheet übernimmt er Werte und Formatierungen beim anderen nur die Werte. Vielleicht könnt ihr mir da helfen.
https://www.herber.de/bbs/user/150787.xls
Mit freundlichen Grüßen
Björn

Sub test()
Dim Kandidat As String
Dim BoVorhanden As Boolean
Dim WsTabelle As Worksheet
Dim wsGesamt As Worksheet
Dim FreieSpalte As Long
Dim AnzahlBenutzterSpalten As Long
'Skript soll nur die Werte aus Bereich Tabelle1 B2:B4 in Tabelle2 die erste freie Spalte kopieren
'und nur die Werte aus Tabelle 1 A2:B4 in ein neues Tabellenblatt mit Namen aus Tabelle1 A2 kopieren
'im Falle eines schon vorhandenen Tabellenblatts soll eine Abfrage zum Überschreiben erscheinen
Kandidat = Sheets("Tabelle1").Range("B2").Text
Set wsGesamt = Sheets("Gesamt")
For Each WsTabelle In Worksheets 'Abfrage Start ob Kandidat schon eingetragen wurde
If WsTabelle.Name = Kandidat Then
BoVorhanden = True
Exit For
End If
Next WsTabelle
' Bestimme Spalte für den neuen Eintrag
AnzahlBenutzterSpalten = Tabelle2.UsedRange.Columns.Count
FreieSpalte = Tabelle2.UsedRange.Columns(AnzahlBenutzterSpalten).Column + 1
If BoVorhanden Then 'Falls Kandidat schon vorhanden, Überschreiben ja / nein
If MsgBox("Kandidat ist bereits eingetragen! Überschreiben?", vbYesNo) = vbYes Then 'Ja -> alten Eintrag löschen und neu eintragen
Dim cell
' Finde den Kandidaten in dem Tabellenblatt "Gesamt"
With wsGesamt.Range("A2").EntireRow
Set cell = .Find(What:=Kandidat, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
End With
If cell Is Nothing Then
MsgBox Kandidat & "  Kandidat in Gesamt nicht gefunden! - Bitte prüfen. Abbruch": Exit Sub
End If
' Wert in der Gesamt-Übersicht erseten
Tabelle1.Range("B2:B4").Copy
cell.PasteSpecial xlPasteValuesAndNumberFormats
' Wert in Einzeltabelle ersetzen
WsTabelle.Cells(2, 2).PasteSpecial xlPasteValuesAndNumberFormats
' Fertig mit Copy&Paste
Application.CutCopyMode = False
Else
MsgBox ("Abgebrochen") 'Nein -> Abbruch
End If
Else 'Kandidat noch nicht vorhanden neues Blatt wird erstellt
Tabelle1.Range("B2:B4").Copy
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValuesAndNumberFormats
Worksheets("Kandidatdummy").Activate
ActiveSheet.Copy before:=Sheets("Kandidatdummy")
' Das eben eingefügt Blatt ist aktiv, unabhängig vom Namen
ActiveSheet.Name = Sheets("Tabelle1").Range("B2").Text
End If
End Sub

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

Betreff
Datum
Anwender
Anzeige
AW: Format und Werte in Sheet kopieren
31.01.2022 13:46:21
{Boris}
Hi,

Bei einem Sheet übernimmt er Werte und Formatierungen beim anderen nur die Werte.
Nein, es werden überall nur Werte eingefügt.
Was möchtest Du von wo genau wohin genau kopieren?
VG, Boris
AW: Format und Werte in Sheet kopieren
31.01.2022 14:00:16
{Boris}
Hi,
hier mal Dein abgeänderter Code:

Option Explicit
Sub Kopieren()
Dim Leerzell As Range
Dim lngLastZ As Long
With Worksheets("Tabelle2")
Set Leerzell = Sheets("Tabelle2").Range("A3:G3").Find(What:="")
End With
MsgBox "Zelle:" & Leerzell.Address
lngLastZ = Sheets("Tabelle2").Cells(Rows.Column, 4).End(xlUp).Row
Worksheets("Tabelle1").Range("B2:B4").Copy Worksheets("Tabelle2").Range(lngLastZ + 1 & 3)
End Sub
Sub Message()
MsgBox "Hello World"
End Sub
Sub test()
Dim Kandidat As String
Dim BoVorhanden As Boolean
Dim WsTabelle As Worksheet
Dim wsGesamt As Worksheet
Dim FreieSpalte As Long
Dim AnzahlBenutzterSpalten As Long
'Skript soll nur die Werte aus Bereich Tabelle1 B2:B4 in Tabelle2 die erste freie Spalte kopieren
'und nur die Werte aus Tabelle 1 A2:B4 in ein neues Tabellenblatt mit Namen aus Tabelle1 A2 kopieren
'im Falle eines schon vorhandenen Tabellenblatts soll eine Abfrage zum Überschreiben erscheinen
Kandidat = Sheets("Tabelle1").Range("B2").Text
Set wsGesamt = Sheets("Gesamt")
For Each WsTabelle In Worksheets 'Abfrage Start ob Kandidat schon eingetragen wurde
If WsTabelle.Name = Kandidat Then
BoVorhanden = True
Exit For
End If
Next WsTabelle
' Bestimme Spalte für den neuen Eintrag
AnzahlBenutzterSpalten = Tabelle2.UsedRange.Columns.Count
FreieSpalte = Tabelle2.UsedRange.Columns(AnzahlBenutzterSpalten).Column + 1
If BoVorhanden Then 'Falls Kandidat schon vorhanden, Überschreiben ja / nein
If MsgBox("Kandidat ist bereits eingetragen! Überschreiben?", vbYesNo) = vbYes Then 'Ja -> alten Eintrag löschen und neu eintragen
Dim cell
' Finde den Kandidaten in dem Tabellenblatt "Gesamt"
With wsGesamt.Range("A2").EntireRow
Set cell = .Find(What:=Kandidat, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
End With
If cell Is Nothing Then
MsgBox Kandidat & "  Kandidat in Gesamt nicht gefunden! - Bitte prüfen. Abbruch": Exit Sub
End If
' Wert in der Gesamt-Übersicht erseten
Tabelle1.Range("B2:B4").Copy
cell.PasteSpecial xlPasteValues
cell.PasteSpecial xlPasteFormats
' Wert in Einzeltabelle ersetzen
WsTabelle.Cells(2, 2).PasteSpecial xlPasteValues
WsTabelle.Cells(2, 2).PasteSpecial xlPasteFormats
' Fertig mit Copy&Paste
Application.CutCopyMode = False
Else
MsgBox ("Abgebrochen") 'Nein -> Abbruch
End If
Else 'Kandidat noch nicht vorhanden neues Blatt wird erstellt
Tabelle1.Range("B2:B4").Copy
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValuesAndNumberFormats
Worksheets("Kandidatdummy").Activate
ActiveSheet.Copy before:=Sheets("Kandidatdummy")
' Das eben eingefügt Blatt ist aktiv, unabhängig vom Namen
ActiveSheet.Name = Sheets("Tabelle1").Range("B2").Text
End If
End Sub
VG; Boris
Anzeige
AW: Format und Werte in Sheet kopieren
31.01.2022 14:38:32
Björn
Vielen Dank, funktioniert!!! Ich habe noch xlPasteColumnWidths hinzugefügt, was mir jetzt noch fehlt ist die Zeilenhöhe, die aber anscheinend nicht analog mit xlPasteRowHeights kopiert wird.

Tabelle1.Range("B2:B4").Copy
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteValues
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteFormats
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteColumnWidths
wsGesamt.Cells(2, FreieSpalte).PasteSpecial xlPasteRowHeights
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValues
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteFormats
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteColumnWidths
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteRowHeights
Worksheets("Kandidatdummy").Activate
ActiveSheet.Copy before:=Sheets("Kandidatdummy")
' Das eben eingefügt Blatt ist aktiv, unabhängig vom Namen
ActiveSheet.Name = Sheets("Tabelle1").Range("B2").Text

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige