nach Eingabe formatierten Inhalt kopieren

Question

Hallo ihr freundlichen Helfer,
ich habe mal wieder ein Problem beim kopieren von Zellinhalten.
Nach eingabe in eine Tabelle, werden die Einträge formatiert und sollen jetzt mit Formatierung sortiert und kopiert werden!
(Die Formatierung ist in den Eingabefeldern hinterlegt)
Es ist eine Benutzerdefinierte Formatierung ("N"#),
in allen Zellen wird nur ein Buchstabe vorgesetzt.
schon mal danke
ulle


Sub CNCspeichern()


Dim verz, dname As String
verz = Cells(1, 5)
dname = Cells(2, 2) & ".xls"
'Achtung richtiges Laufwerk eintragen!!
'ActiveWorkbook.SaveAs Filename:=("G:\" & verz & "\" & dname) ', FileFormat:=xlNormal
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

Application.ScreenUpdating = False

'Einträge sortieren-Leerzellen entfernen

Range("K10").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column + 0) = ActiveSheet.Range("K5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("L5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("M5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("N5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("O5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("P5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("Q5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("R5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("S5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("T5").Value

'sortierten Block kopieren

ActiveSheet.Range("K6:T6").Copy
Range("A1000").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column + 0).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False 'True

ActiveSheet.Range("K6:T6").Delete
'ActiveSheet.Range("L5:T5").ClearContents

Application.CutCopyMode = False

'Windows(dname).Activate

Range("K5").Select



End Sub

Answer 1

Hallo ulle,

und was ist jetzt deine Frage? Das Makro funktioniert nicht? Das Makro macht nich dass, was Du möchtest?

Du müsstest schon etwas genauer werden. Eventuell lädst Du auch eine Beispieldatei bei z.B. http://www.file-upload.net/ hoch und postest dann hier den Link, den Du erhältst. Eventuell wird dadruch einiges klarer.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 2

Sorry Oliver,
wenn mann das Problem hat erkennt mann die Frage.
Beim Kopieren geht die Formatierung verloren oder wird garnicht gesagt das sie mit soll!
gruß Ulle

Answer 3

Hallo Oliver,
ich habe die Datei mal hochgeladen!

http://www.file-upload.net/download-1925803/Test2.xls.html

Gruß Ulle

Answer 4

Hi,

Ich gehe einmal davon aus, dass die Zellen K5 bis T5 Deine formatierten "Eingabe-Zellen" sind. Dann würde das Sortieren und Kopieren bei mir wie folgt aussehen:

Dim lngFirstRow As Long
Dim rngZelle As Range
Dim lngCount As Long
lngFirstRow = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Each rngZelle In Range("K5:T5")
If rngZelle.Value <> "" Then
rngZelle.Copy
Cells(lngFirstRow, 1 + lngCount).PasteSpecial Paste:=xlPasteValues
Cells(lngFirstRow, 1 + lngCount).PasteSpecial Paste:=xlPasteFormats
lngCount = lngCount + 1
End If
Next
Application.CutCopyMode = False

bye
malSchauen

Answer 5

Hallo Ulle,

also im Makro in dem Bereich

Range("K10").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column + 0) = ActiveSheet.Range("K5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("L5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("M5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("N5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("O5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("P5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("Q5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("R5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("S5").Value
Range("T6").End(xlToLeft).Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = ActiveSheet.Range("T5").Value

kopierst Du nur die Werte, nicht aber die Formate der Zellen. Du dürftest dort nicht mit dem Gleichheitszeichen, also

Cells(ActiveCell.Row + 1, ActiveCell.Column + 0) = ActiveSheet.Range("K5").Valuesondern Du musst auch hier richtig kopieren und einfügen. Also

ActiveSheet.Range("K5").Copy
Cells(ActiveCell.Row + 1, ActiveCell.Column + 0).PasteSpecial Paste:=xlPasteAll
Außerdem musst Du dann die Zeile

Cells(ActiveCell.Row + 1, ActiveCell.Column + 0).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _in

Cells(ActiveCell.Row + 1, ActiveCell.Column + 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
ändern, also Paste:=xlValues in Paste:=xlPasteAll, damit auch hier die Formate mit eingefügt werden.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 6

Hallo malSchauen,
deine Lösung ist Super und funktioniert einwandfrei!!!!!!!
So eine kurze Lösung hätte ich nie gefunden.
Es währe schön, den Fehler in meinen Makro für mein VBA-Wissen zu kennen.
Für mein Makro gibts bestimmt eine Ergänzung, die ich verstehe.
trotzdem Danke
Gruß Ulle

Answer 7

Hallo ulle,

das steht in meiner AW5, warum das bei Dir nicht funktioniert hat.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 8

Halt ich nehme alles zurück.
Oliver, Deine Lösung ist genau sogut und ich verstehe sie auch.
Aber nach Prüfung beider Varianten habe ich festgestellt das auch die Rahmen mit kopiert werden, was nicht so schön ist.
Wie ich euch kenne, habt ihr auch dafür eine Lösung!
Danke Ulle

Answer 9

Hallo Ulle,

sollte das nicht? Siehe AW2

Beim Kopieren geht die Formatierung verloren oder wird garnicht gesagt das sie mit soll!

Was von welcher Formatierung soll denn nun mit in die neuen Zellen?

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 10

Hi,

Wenn es nur um die Werte und Zahlenformate ("N" #) geht,
dann verwende bei der Lösung von Coros aus AW5
eben Paste:=xlPasteValuesAndNumberFormats
anstatt des Paste:=xlPasteAll.

Wunder Dich dann aber nicht, das die Schrift dann nicht
kursiv, bunt oder fett ... ist.

bye
malSchauen