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