在Excel VBA中，我尝试仅复制单元格的边框并将其粘贴到另一个单元格上（不更改值、数字格式等）

Question

这个想法是，如果我在具有所需边框格式的单元格上按 ctrl+c，然后单击我想要应用所需边框的新单元格，然后我可以运行宏，并且只会应用单元格边框。澄清一下，原始字体、数字格式、大小、颜色、对齐方式在现在具有新边框的单元格中不会发生变化。

更新

示例代码：

Cells(1, 1).Formula = ActiveCell.Formula
Cells(1, 1).Font.Color = ActiveCell.Font.Color

Cells(1, 1).Font.ColorIndex = ActiveCell.Font.ColorIndex
Cells(1, 1).Font.Bold = ActiveCell.Font.Bold
Cells(1, 1).Font.FontStyle = ActiveCell.Font.Name
Cells(1, 1).Font.Size = ActiveCell.Font.Size
Cells(1, 1).NumberFormat = ActiveCell.NumberFormat
Cells(1, 1).HorizontalAlignment = ActiveCell.HorizontalAlignment
Cells(1, 1).VerticalAlignment = ActiveCell.VerticalAlignment
Cells(1, 1).WrapText = ActiveCell.WrapText
ActiveSheet.Paste
ActiveCell.Formula = Cells(1, 1).Formula
ActiveCell.Font.Color = Cells(1, 1).Font.Color
ActiveCell.Font.ColorIndex = Cells(1, 1).Font.ColorIndex
ActiveCell.Font.Bold = Cells(1, 1).Font.Bold
ActiveCell.Font.Name = Cells(1, 1).Font.Name
ActiveCell.Font.Size = Cells(1, 1).Font.Size
ActiveCell.NumberFormat = Cells(1, 1).NumberFormat
ActiveCell.HorizontalAlignment = Cells(1, 1).HorizontalAlignment
ActiveCell.VerticalAlignment = Cells(1, 1).VerticalAlignment
ActiveCell.WrapText = Cells(1, 1).WrapText
Cells(1, 1).Clear

这可行，但会导致 ActiveSheet.paste 行出现调试错误。但如果我通过调试再次运行它，它就会起作用。

第二次更新

不幸的是，对于像我这样的外行来说，你的解决方案似乎有点太复杂了。我确实相信我已经解决了我正在寻找的问题：

Sub Test()

Dim RowRef, ColRef, Alignment As Integer
Dim Color As Double
Dim NumForm, Formula As String

RowRef = ActiveCell.Row
ColRef = ActiveCell.Column

NumForm = Cells(RowRef, ColRef).NumberFormat
Formula = Cells(RowRef, ColRef).Formula
Color = Cells(RowRef, ColRef).Font.Color
Alignment = Cells(RowRef, ColRef).HorizontalAlignment

Cells(RowRef, ColRef).PasteSpecial (xlPasteAll)

Cells(RowRef, ColRef).NumberFormat = NumForm
Cells(RowRef, ColRef).Formula = Formula
Cells(RowRef, ColRef).Font.Color = Color
Cells(RowRef, ColRef).HorizontalAlignment = Alignment

End Sub

我可以简单地添加更多我想要保持相同格式的特征，但解决方案的要点似乎如上所述。如果您有时间确认或提供有关如何进一步改进的任何指导，请告诉我。

Answer 1

这是一个答案……但也不是——因为它不能完全按原样工作，但也许有人可以填补空白。

必须有一种方法可以使用 Borders

 对象来执行此操作，该对象是四个 

Border

 对象的集合。 

我以为我能够通过

For Each

 枚举或范围的 

XlBordersIndex 属性来

Borders

循环，例如：For Each b in Range("A1:A4").Border

...然后设置属性，例如

XlBorderWeight

和

XlLineStyle

。

但是，我尝试了一些可能的解决方案，但没有任何效果达到预期。

例如：

Sub copyBorders()
    Dim rgFrom As Range:  Set rgFrom = ThisWorkbook.Sheets("Sheet1").Range("A1")
    Dim rgTo As Range:    Set rgTo = ThisWorkbook.Sheets("Sheet1").Range("C1")

    Dim bFrom As Borders: Set bFrom = rgFrom.Borders
    Dim bTo As Borders:   Set bTo = rgTo.Borders

    Dim arr, bs
    arr = Array(xlDiagonalDown, xlDiagonalUp, xlEdgeBottom, xlEdgeLeft, _
                xlEdgeRight, xlEdgeTop, xlInsideHorizontal, xlInsideVertical)

    For Each bs In arr  'same as using `For bs = 5 to 12`
        With bFrom(bs)
            bTo(bs).Color = .Color
            bTo(bs).ColorIndex = .ColorIndex
            bTo(bs).LineStyle = .LineStyle
            bTo(bs).TintAndShade = .TintAndShade
            bTo(bs).Weight = .Weight
        End With
    Next bs
End Sub

...以及我尝试将 

C1

的边框与 A1 匹配的

奇怪的结果

：

我自己可能永远不会有理由使用这个，但我仍然很好奇如何使这个方法发挥作用，并且对为什么我得到这样的结果感到困惑。

我首先想到/希望它会像这样简单：

---

Range1.Borders = Range2.Borders

...或者至少是这样的：

Range1.Borders(xlEdgeRight) = Range2.Borders(xlEdgeRight)

...但没有这样的运气。

Answer 2

Excel VBA - 当活动/选定单元格不同时获取复制的单元格地址

在

ThisWorkbook

中放入以下代码：

Option Explicit

Private Sub Workbook_Open()
    Application.OnKey "^c", "CopyEvent"
End Sub

在模块中，放置以下代码：

Option Explicit

Dim CopyCells As Range

Private Sub CopyEvent()
    Set CopyCells = Selection
    Selection.Copy
End Sub

Public Sub PasteBorders()
    If Not CopyCells Is Nothing Then
        ActiveCell.Borders().LineStyle = CopyCells.Borders().LineStyle
        ActiveCell.Borders().Color = CopyCells.Borders().Color
    End If
End Sub

保存/关闭工作簿并重新打开它以首次运行Workbook_Open。

诀窍是复制的范围通常无法访问，因此当按下 Ctrl-C 时会显式保存它。运行 PasteBorders 代码时，它仅复制所选范围内的线条样式和颜色。

Answer 3

ashleedawg 的代码已经基本完成，只有一个问题。 正如 TechnoDabbler 所指出的，在设置边框属性时，后台似乎发生了一些事情。 在我看来，当设置边框的 lineStyle 时，颜色会自动设置为 0。并且当设置不存在的边框的粗细（即 linestyle = xlLineStyleNone）时，会创建该边框。

因此，你只需添加一个 if 语句即可使其工作：

For Each bs In arr
    With bFrom(bs)
        If Not .LineStyle = xlLineStyleNone Then 
            bTo(bs).Color = .Color
            bTo(bs).ColorIndex = .ColorIndex
            bTo(bs).LineStyle = .LineStyle
            bTo(bs).TintAndShade = .TintAndShade
            bTo(bs).Weight = .Weight
        End If
    End With
Next bs