Hallo Leute,
Ich habe eine Formel gefunden, die mir eine markierte Range alle Formeln ohne Bezugsänderung in einen neuen Bereich kopiert.
Ich habe sie aus dem Internet gezogen und sie Funktioniert eigendlich ganz gut, aber...
Wenn ich eine komplette Zeile Markiere versucht sie die ganzen Leeren Zellen in der Zeile bis XFD Analog dazu bei der Spalte bis 1048576 zu Kopieren.
Im Prinzip richtig, aber dauert zu lange.
Also meine Idee: mit dem Code
"letztespalte = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
LetzteZeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row"
die letzte benutzte Spalte bzw. Zeile feststellen und den Range zu begrenzen.
Es müsste also eine Abfrage gemacht werden, das wenn die Selection über die Letzten Werte hinausgeht, die Letzten Werte eingetragen werden.
Damit würde man dann viel Zeit sparen und die Formel wäre "Freundlicher"
Die zweite Änderung wäre eine Automatische Erkennung ob eine Matrixformel kopiert werden soll.
Ich habe aber keine Ahnung wie VBA erkennen kann ob eine Matrixformel in der Zelle vorhanden ist.
Dies müsste dann ebenfalls in die Stelle von dem Code "If .HasFormula Then"eingebaut werden und zwischen den beiden Codes "varAuswahl.Offset(Zeile - 1, Spalte - 1).Formula = .Formula ' für Standardformeln
' varAuswahl.Offset(Zeile - 1, Spalte - 1).FormulaArray = .FormulaArray 'für Matrixformeln" wechseln.
Ich habe es leider nicht wirklich hinbekommen.
Für euch Profis wahrscheinlich ein Klacks.
Das wäre dann ein echt gut Funktionierender Code zu Kopieren von mehreren Formeln ohne den Bezug zu ändern und ohne alle Formeln mit $ zu versehen.
Sub Formel_Kopieren()
'vor dem Start des Makros den Zellbereich mit den zu kopierenden Formeln selektieren
'Standard-Formeln kopieren ohne Anpassung der Zellbezüge
Dim Bereich As Range, Zeile As Long, Spalte As Long
Dim varAuswahl As Range
On Error GoTo Fehler
Set Bereich = Selection
Set varAuswahl = Application.InputBox( _
Prompt:="Bitte Startzelle für Ziel-Kopieren der Formeln auswählen", _
Title:="Formeln kopieren ohne Bezugsanpassung", _
Type:=8)
For Zeile = 1 To Bereich.Rows.Count
For Spalte = 1 To Bereich.Columns.Count
With Bereich.Cells(Zeile, Spalte)
If .HasFormula Then
varAuswahl.Offset(Zeile - 1, Spalte - 1).Formula = .Formula ' für Standardformeln
' varAuswahl.Offset(Zeile - 1, Spalte - 1).FormulaArray = .FormulaArray 'für Matrixformeln
Else
If Not IsEmpty(.Cells) Then
varAuswahl.Offset(Zeile - 1, Spalte - 1).Value = .Value
Else
varAuswahl.Offset(Zeile - 1, Spalte - 1).ClearContents
End If
End If
End With
Next
Next
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 424 'Keine Zelle in Inputbox gewählt
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Vielen Dank, und ich hoffe das dieser Code dann auch anderen Leuten hilft.
Gruß
Bernd
|