Question

我是excel VBA并尝试准备VBA插件的新手：

当前情况：在我们的Excel电子表格列中，在B列中打出了一致的不同财务行项目和值。

我们有一个内部工具，可以在任何标签中使用所有公式和数字。但是，如果我们使用相同的工具去除颜色，它也会删除在单元格中应用的原始颜色，并且制作为白色

我喜欢创建VBA，它只会复制A列的颜色，并在B，C，D列中粘贴相同的颜色（只有颜色，没有其他格式）。

我创建了一个VBA代码，可以帮助我将粗体复制到不同的列，现在而不是粗体我想要将颜色粘贴到不同的列中

Sub FilterBold()
    Dim myRange As Range
    On Error GoTo Canceled
    Set myRange = Application.InputBox(Prompt:="Please Select a Range", Title:="InputBox Method", Type:=8)
    myRange.Select
    Application.ScreenUpdating = False
    For Each myRange In Selection
        If myRange.Font.Bold = True Then
            myRange.Columns("b:GR").Font.Bold = True
        End If
    Next myRange
    Application.ScreenUpdating = True
    Canceled:
End Sub

Answer 1

假设A列中的所有单元格（源col）具有相同的颜色...否则它将为目标列（C）提供黑色

Range("C:C").Interior.Color = Range("A:A").Interior.Color

update-1 col by col

Sub foo2()

Dim ARows, CRows As Long
Dim SourceRange, TargetRange As String

Dim SFirstRow, TfirstRow As Integer ' these are the starting points for the coluring of the col, in case you have header which is not colured.
SFirstRow = 2 ' if you have header which is to be ignored... otherwise make it 1 
TfirstRow = 2


 ARows = Range("A" & Rows.Count).End(xlUp).Row
 CRows = Range("C" & Rows.Count).End(xlUp).Row

     SourceRange = "A" & SFirstRow & ":A" & ARows
     TargetRange = "C" & TfirstRow & ":C" & CRows

Range(TargetRange).Interior.Color = Range(SourceRange).Interior.Color



End Sub

更新2-以逐行进行

Sub foo2()

Dim ARows, CRows As Long
Dim SourceRange, TargetRange As String

Dim SFirstRow, indexS As Integer ' these the starting points for the coluring of the col, in case you have header which is not colured.
SFirstRow = 1



 ARows = Range("A" & Rows.Count).End(xlUp).Row
 CRows = Range("C" & Rows.Count).End(xlUp).Row



Application.ScreenUpdating = False



For indexS = SFirstRow To ARows Step 1

ActiveSheet.Range("B" & indexS).Interior.Color = ActiveSheet.Range("A" & indexS).Interior.Color
ActiveSheet.Range("C" & indexS).Interior.Color = ActiveSheet.Range("A" & indexS).Interior.Color
ActiveSheet.Range("D" & indexS).Interior.Color = ActiveSheet.Range("A" & indexS).Interior.Color

Next

Application.ScreenUpdating = True

End Sub`

update-3，此代码将excelsheet中使用的最后一列和B列中的颜色（可以更改）提取到工作表中最后使用的列

Sub foo3()

Dim ATotalRows As Long
Dim SourceRange, TargetRange As String
Dim TargetSheet As Worksheet
Dim SFirstRow, SFirstCol, indexRows, indexCols, TotalCols As Long ' these the starting points for the coluring of the col, in case you have header which is not colured.


Set TargetSheet = ThisWorkbook.Worksheets("Sheet1") ' Enter The name of your worksheet here

SFirstRow = 1  ' The Row from where to start
SFirstCol = 2  ' The Column from where to start coloring, in this case from the second column- 'B'
SLastCol= 10 ' index number of last col to be colored


ATotalRows = TargetSheet.Range("A" & Rows.Count).End(xlUp).Row





Application.ScreenUpdating = False



For indexRows = SFirstRow To ATotalRows Step 1
    For indexCols = SFirstCol To SLastCol Step 1 ' starts coluring form B
        TargetSheet.Cells(indexRows, indexCols).Interior.Color = TargetSheet.Range("A" & indexRows).Interior.Color
    Next
Next

Application.ScreenUpdating = True







End Sub

Answer 2

您可以使用以下代码执行此操作：

Sub FilterColor()
    Dim myRange As Range
    Dim rng As Range
    Dim sh As Worksheet
    Dim i As Long
    Dim LastRow As Long

    Set sh = Thisworkbook.Sheets("Sheet1")
    LastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    Set myRange = sh.Range("A1:A" & LastRow)

    Application.ScreenUpdating = False

    For Each rng In myRange
        For i = 1 To 10
            rng.Offset(0, i).Interior.Color = rng.Interior.Color
        Next i
    Next rng

    Application.ScreenUpdating = True

End Sub

此代码在A列中具有动态范围，该范围为该范围内的每个单元格循环，然后复制颜色并粘贴到每个列中。代码将粘贴的列数由变量i给出。在这种情况下，代码会将颜色格式粘贴到接下来的10列中。

请务必将此.Sheets("Sheet1")更改为工作表的名称。

颜色格式化excel复制到相应的行

2 个答案: