Copy format from one column to others

dodom75

dodom75

Board Regular
Joined
Jul 10, 2008
Messages
136
At the end of a macro that pulls over data from another spreadsheet I have the following code to copy the color from one of the copied columns to other columns.

The problem I am having is where I have range ("B7"), it is just pulling the color of that cell where I actually need it to be copying the format of cell B7 should copy to E7-I7, B8 should copy to E8-I8, etc. I have tried range ("B:B"), range (B7:B700), but nothing is working. Any assistance you can provide will be greatly appreciated.


Code: 
 [LEFT]With OutSH
    .Range("A6:J" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=.Range("A6"), order1:=xlAscending, header:=xlYes
    .Range("E7:I" & .Cells(Rows.Count, 1).End(xlUp).Row).Interior.ColorIndex = .Range("B7").Interior.ColorIndex
  End With[/LEFT]

Thanks,
Danielle:confused:​
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Try

Code: 
Dim i As Long
With OutSh
    For i = 7 To Range("B" & Rows.Count).End(xlUp).Row
        .Range("E" & i & ":I" & i).Interior.ColorIndex = .Range("B" & i).Interior.ColorIndex
    Next i
End With
 
Upvote 0
Hi, when I put that in it didn't bring over the formating at all. I have put in the full code below, maybe it is something I have in the above?

Code: 
Option Explicit
Private Sub CommandButton1_Click()
  Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
  Dim DataCol As Integer, OutRow As Long, i As Long
  Dim arr As Variant
  Set OutSH = Sheets("Internal Project Plan")
  Set TemplateSH = Sheets("Master Template")
  
  For Each ce In Range("B13:B70")
    If ce = "Yes" Then
      DataCol = WorksheetFunction.Match(ce.Offset(0, -1).Value, TemplateSH.Rows("1:1"), 0)
      With TemplateSH
        For i = 2 To 650
          If .Cells(i, DataCol).Value = "x" Then
          'check to see if it already exists and only proceed if it does not
            If WorksheetFunction.CountIf(OutSH.Range("A:A"), TemplateSH.Cells(i, 1).Value) = 0 Then
              OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
              OutSH.Cells(OutRow, 1).Value = .Cells(i, 1).Value
              OutSH.Cells(OutRow, 2).Value = .Cells(i, 4).Value
              OutSH.Cells(OutRow, 3).Value = .Cells(i, 10).Value
              OutSH.Cells(OutRow, 4).Value = .Cells(i, 5).Value
              OutSH.Cells(OutRow, 10).Value = .Cells(i, 63).Value
            End If
          End If
        Next i
      End With
    End If
  Next ce
  Application.StatusBar = "Transferring Headings"
  arr = Array(2, 15, 77, 87, 461, 507, 534, 553, 582)
  With TemplateSH
    For i = LBound(arr) To UBound(arr)
      OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      .Cells(arr(i), 1).Copy Destination:=OutSH.Cells(OutRow, 1)
      OutSH.Cells(OutRow, 1).Value = .Cells(arr(i), 1).Value
      .Cells(arr(i), 4).Copy Destination:=OutSH.Cells(OutRow, 2)
      OutSH.Cells(OutRow, 2).Value = .Cells(arr(i), 4).Value
      .Cells(arr(i), 10).Copy Destination:=OutSH.Cells(OutRow, 3)
      OutSH.Cells(OutRow, 3).Value = .Cells(arr(i), 10).Value
      .Cells(arr(i), 5).Copy Destination:=OutSH.Cells(OutRow, 4)
      OutSH.Cells(OutRow, 4).Value = .Cells(arr(i), 5).Value
      .Cells(arr(i), 63).Copy Destination:=OutSH.Cells(OutRow, 10)
      OutSH.Cells(OutRow, 10).Value = .Cells(arr(i), 63).Value
    Next i
  End With
  'sort output data
  Application.StatusBar = "Sorting Output"
  With OutSH
    .Range("A6:J" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=.Range("A6"), order1:=xlAscending, header:=xlYes
    .Range("E7:I" & .Cells(Rows.Count, 1).End(xlUp).Row).Interior.ColorIndex = .Range("B7").Interior.ColorIndex
  End With
    
   
  Application.StatusBar = False
End Sub
 
Upvote 0
I can't see anything in that code that would affect this.

Please try this. On a 'spare' sheet type in some values in B7 down and colour the cells. Then run this

Code: 
Sub cols()
Dim i As Long
With ActiveSheet
    For i = 7 To Range("B" & Rows.Count).End(xlUp).Row
        .Range("E" & i & ":I" & i).Interior.ColorIndex = .Range("B" & i).Interior.ColorIndex
    Next i
End With
End Sub

Does that work (it does for me).
 
Upvote 0
Thank you,

I couldn't get this to work within the current code but I built a separate macro, it did work.

New question: I have a command button, how can I make the different macro's run with just the click of the 1 button?
 
Upvote 0
I'm not sure that I understand that question but please start a new thread for it as it is a completely different question :)
 
Upvote 0
Hi, what is the correct code to use to change it from
Code: 
With ActiveSheet
to addressing the workseet "Internal Project Plan" (Sheet3). I tried changing the With "Activesheet" to With "Internal Project Plan" but it didn't work.

Thanks
 
Upvote 0
Hi, thank you again, I tried the with sheets but it still would'nt work so I put in and made it switch to the internal project plan and then call the macro (with activesheet) and it works perfectly.

Thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Locked
  • Question
Range in worksheet1 Insert into worksheet2 from row 2
Replies
1
Views
220
Fluff
Fluff
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
843
Joe4
Joe4
T
  • Question
VBA code to manage slicer items after selection crash constantly my excel software
Replies
1
Views
224
Fluff
Fluff
P
  • Question
update listbox from 2 different sheets
2
Replies
11
Views
448
Patriot2879
P
B
  • Solved
Use Sheet1:D5 to find matching cell in Sheet2 Column A:A, and select cell (or row)
Replies
1
Views
127
brianv
B

Forum statistics

Threads
1,216,477
Messages
6,130,862
Members
449,600
Latest member
inborntarmac

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top