Nur Rahmen kopieren/einfügen Bereich
23.10.2014 09:08:10
Lutz
ich hatte schon mal diese Frage gestellt und auch eine Antwort bekommen - vielen Dank dafür.
Nur ist die Lösung noch nicht wirklich befriedigend.
Ich muß in diversen Dateien oft die Rahmen und die Füllfarbe (diverse Farben, kaum zu unterscheiden) kopieren - aber eben nichts anderes.
Hier die Lösung aus dem Forum:
Function Set_Borders(rngSource As Range, rngdest As Range)
Dim i As Integer
For i = 7 To 10
With rngdest.Borders(i)
.LineStyle = xlNone 'hier löscht Du den Rahmen der Zielzelle erst ab
If rngSource.Borders(i).LineStyle xlNone Then
.LineStyle = rngSource.Borders(i).LineStyle
.Weight = rngSource.Borders(i).Weight
.Color = rngSource.Borders(i).Color
End If
End With
Next
End Function
Sub AtestB()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ActiveCell
Set rng2 = Application.InputBox("Select a range", "Get Range", Type:=8)
Call Set_Borders(rng1, rng2)
End Sub
Für die Füllfarbe gab es etwas ähnliches:
Function Set_Color(rngSource As Range, rngdest As Range)
rngdest.Interior.Color = rngSource.Interior.Color
End Function
Mein Problem: hier wird nur die Füllfarbe/Rahmen einer Zelle kopiert und nicht des gesamten markierten Bereichs.
Es sollte so funktionieren:
Z.B. markiere ich den Bereich A1:A100 bevor ich das Makro starte
Jetzt starte ich das Makro und werde nach dem Zielbereich gefragt:
Ich wähle z.B. B1:D100
Nun sollte B1:D100 die gleichen Rahmen und Fürllfarbe haben wie der Bereich A1:A100
Da ich manchmal nur Rahmen und manchmal auch nur Füllfarben kopieren muß wäre es schön das jeweils auch als getrenntes Makro zu haben - so wie jetzt:
RAHMEN UND FÜLLFARBE:
Function Set_BordersAndColor(rngSource As Range, rngdest As Range)
Dim i As Integer
For i = 7 To 10
With rngdest.Borders(i)
.LineStyle = xlNone 'hier löscht Du den Rahmen der Zielzelle erst ab
If rngSource.Borders(i).LineStyle xlNone Then
.LineStyle = rngSource.Borders(i).LineStyle
.Weight = rngSource.Borders(i).Weight
.Color = rngSource.Borders(i).Color
End If
End With
rngdest.Interior.Color = rngSource.Interior.Color
Next
End Function
Sub AtestBaC()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ActiveCell 'oder Bereich?
Set rng2 = Application.InputBox("Select a range", "Get Range", Type:=8)
Call Set_BordersAndColor(rng1, rng2)
End Sub
Function Set_Borders(rngSource As Range, rngdest As Range)
Dim i As Integer
For i = 7 To 10
With rngdest.Borders(i)
.LineStyle = xlNone 'hier löscht Du den Rahmen der Zielzelle erst ab
If rngSource.Borders(i).LineStyle xlNone Then
.LineStyle = rngSource.Borders(i).LineStyle
.Weight = rngSource.Borders(i).Weight
.Color = rngSource.Borders(i).Color
End If
End With
Next
End Function
Sub AtestB()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ActiveCell
Set rng2 = Application.InputBox("Select a range", "Get Range", Type:=8)
Call Set_Borders(rng1, rng2)
End Sub
Function Set_Color(rngSource As Range, rngdest As Range)
rngdest.Interior.Color = rngSource.Interior.Color
End Function
Sub AtestB()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ActiveCell
Set rng2 = Application.InputBox("Select a range", "Get Range", Type:=8)
Call Set_Borders(rng1, rng2)
End Sub
Wenn jemand da eine Lösung hätte wäre das wirklich Klasse - und es würde mir jede Menge arbeit sparen. Ich habe die Frage auch schon oft im Internet gefunden aber nie eine Lösung dafür...
Vielen Dank und viele Grüße Lutz
Anzeige