Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
Screenshot zu InputBox	InputBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema RefEdit
Screenshot zu RefEdit	RefEdit-Seite mit Beispielarbeitsmappe aufrufen

Nur Rahmen kopieren/einfügen Bereich

• Nur Rahmen kopieren/einfügen Bereich von Lutz vom 23.10.2014 09:08:10
• AW: Nur Rahmen kopieren/einfügen Bereich - von fcs am 23.10.2014 12:50:55
  • AW: Nur Rahmen kopieren/einfügen Bereich - von Lutz am 23.10.2014 13:27:30

Betrifft: Nur Rahmen kopieren/einfügen Bereich von: Lutz
Geschrieben am: 23.10.2014 09:08:10

Hallo Excel-Profis,

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

NUR RAHMEN:

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

NUR FÜLLFARBE:

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

Betrifft: AW: Nur Rahmen kopieren/einfügen Bereich von: fcs
Geschrieben am: 23.10.2014 12:50:55

Hallo Lutz,

mit folgenden Ergänzungen werden die Zellen eines Zellbereiches nacheinander abgearbeitet.

Gruß
Franz

Sub AtestB()
  Dim Spalte As Long, Zeile As Long
   Dim rng1 As Range
   Dim rng2 As Range
   
   Set rng1 = Selection 'Source-Bereich vor Makroausführung selektieren
   'Destination-Breich wählen
   Set rng2 = Application.InputBox("Select a range", "Get Range", Type:=8)
   For Zeile = 1 To rng2.Rows.Count
   For Spalte = 1 To rng2.Columns.Count
      Call Set_Borders(rng1.Cells(Zeile, Spalte), rng2.Cells(Zeile, Spalte))
   Next
   Next
End Sub

Betrifft: AW: Nur Rahmen kopieren/einfügen Bereich von: Lutz
Geschrieben am: 23.10.2014 13:27:30

Hallo Franz,

perfect - vielen Dank.


Ich wünsche Dir noch einen schönen Tag und nochmals vielen lieben Dank,


viele Grüße Lutz

Beiträge aus den Excel-Beispielen zum Thema "Nur Rahmen kopieren/einfügen Bereich"