顏色格式Excel中複製到相應的

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 

更新-1 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` 

更新-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的動態範圍，這在該範圍內循環的每個單元格，然後警察y之後，每一列中都有顏色和粘貼。代碼將粘貼的列數由變量i給出。在這種情況下，代碼將在接下來的10列中粘貼顏色格式。

請記得將此.Sheets("Sheet1")更改爲您的工作表的名稱。