Need a little excel coding help

[hshayh0rn]

I'm looking for someone who can expand on that I already have here.

http://www.microsoft.com/office/com...e6762d-b1ce-4ae8-993d-54620e3e5286&sloc=en-us

I'm looking to take the above thread a little further. Right now based on a
value in a cell on sheet 1 the entire row is copied to sheet 2. The problem
is the copied row may have a blank value in column A. Column A has values at
the start of each list and then nothing until a new list is started. I need
the code that was detailed in the above link to look in column A upwards
until it finds a value and then use that value.

Also, the copied column is colored. However, when it's pasted into sheet 2
there is an addiitonal column at the end of the row and obviously that column
wouldn't have the same color as the rest of the row. I need the code to
determine the color of the row and make that column's cell the same color.
For example:

row 3 is copied to sheet 2. Column G is the added column on sheet 2 so we
need to color cell G3 the same color as the row we just copied.

Can anyone help me with this?

 

[Bernie Deitrick]

That was fairly inefficient code... try it like this (no need for looping). I'm not sure where
your code added "column G" - if you are using another event this code will prevent that from
occuring - but this should handle the color issue, as well as the possibly blank cell in column A.

Private Sub Worksheet_Change(ByVal Target As range)
Dim i As Integer
Dim myR As Long

If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 4 Then Exit Sub
If UCase(Target.Value) <> "FAIL" Then Exit Sub

Application.EnableEvents = False
myR = Sheets("Notes").Cells(Rows.Count, 4).End(xlUp).Row
Target.EntireRow.Copy Sheets("Notes").Cells(myR + 1, 1).EntireRow
If Target.EntireRow.Cells(1, 1).Value = "" Then
Worksheets("Notes").range("A" & myR + 1).Value = _
Target.EntireRow.Cells(1, 1).End(xlUp).Value
Else
Worksheets("Notes").range("A" & myR + 1).Value = _
Target.EntireRow.Cells(1, 1).Value
End If
Sheets("Notes").Cells(myR + 1, 1).EntireRow. _
SpecialCells(xlCellTypeConstants).Interior.ColorIndex _
= Target.Interior.ColorIndex


Adden = "Notes!H" & myR
ActiveSheet.Hyperlinks.Add Anchor:=Target, _
Address:="", SubAddress:=Adden, _
TextToDisplay:="Fail"
Application.EnableEvents = True
End Sub




HTH,
Bernie
MS Excel MVP

 

[hshayh0rn]

Ok, that partially worked. I'm now getting the correct name copied from
column A which is great but the color is not coming through. The row your
copying has values in columns A-F and then the destination sheet has an
additional column G that is not present on the source sheet and I'm using
that column for notes. I need column G to have the same colors as column A-F

 

[hshayh0rn]

Also, the hyperlink is shrinking the font of the word fail from 9pt to 7pt.
Can we correct the size in the code too?

 

[Bernie Deitrick]

Is your coloring from conditional formatting? The color 'capture' worked in my testing, as long as
column D (where you enter Fail) has the correct colorindex.

All hyperlinks have a specific style applied to them - you can change the default for the workbook
by using Format / Style.... and selecting "Hyperlink" from the dropdown, and editing that style's
font.

HTH,
Bernie
MS Excel MVP

 

[hshayh0rn]

Are you looking at font color or cell fill color? I am referring to cell fill
color not font color.

 

[Bernie Deitrick]

No, I was working with fill color, but I had assumed constants - Try changing

Sheets("Notes").Cells(myR + 1, 1).EntireRow. _
SpecialCells(xlCellTypeConstants).Interior.ColorIndex _
= Target.Interior.ColorIndex

to

Sheets("Notes").Cells(myR + 1, 1).Resize(1,7).Interior.ColorIndex _
= Target.Interior.ColorIndex


HTH,
Bernie
MS Excel MVP

 

[hshayh0rn]

Perfect!! Can I be a littler greedier? Can you tell me how to add border
lines around that cell? All of the copied cells in the row are coming with
the boarder from the source sheet.

 

[Bernie Deitrick]

Sheets("Notes").Cells(myR + 1, 1).BorderAround xlContinuous, xlThin

Record a macro to get the correct style of line.

HTH,
Bernie
MS Excel MVP

 

[hshayh0rn]

Bernie, I must be doing something wrong. Here is the code I have from you. It
still doesn't put a lines around column G on the destination sheet (NOTES).

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim myR As Long

If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 4 Then Exit Sub
If UCase(Target.Value) <> "FAIL" Then Exit Sub

Application.EnableEvents = False
myR = Sheets("Notes").Cells(Rows.Count, 4).End(xlUp).Row
Target.EntireRow.Copy Sheets("Notes").Cells(myR + 1, 1).EntireRow
If Target.EntireRow.Cells(1, 1).Value = "" Then
Worksheets("Notes").Range("A" & myR + 1).Value = _
Target.EntireRow.Cells(1, 1).End(xlUp).Value
Else
Worksheets("Notes").Range("A" & myR + 1).Value = _
Target.EntireRow.Cells(1, 1).Value
End If
Sheets("Notes").Cells(myR + 1, 1).Resize(1, 7).Interior.ColorIndex _
= Target.Interior.ColorIndex
Sheets("Notes").Cells(myR + 1, 1).BorderAround xlContinuous, xlThin

Adden = "Notes!H" & myR
ActiveSheet.Hyperlinks.Add Anchor:=Target, _
Address:="", SubAddress:=Adden, _
TextToDisplay:="Fail"
Application.EnableEvents = True
End Sub

 

[Bernie Deitrick]

I may have misunderstood what you meant by "that cell" - I thought column A, but maybe (?) you meant
column G. In that case, the second argument for Cells should be 7, not 1:

Sheets("Notes").Cells(myR + 1, 7).BorderAround xlContinuous, xlThin


HTH,
Bernie
MS Excel MVP

 

[hshayh0rn]

Thank you so much for your help!

I may have misunderstood what you meant by "that cell" - I thought column A, but maybe (?) you meant
column G. In that case, the second argument for Cells should be 7, not 1:

Sheets("Notes").Cells(myR + 1, 7).BorderAround xlContinuous, xlThin


HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

You're welcome... I guess that means you got it all to work!

Bernie
MS Excel MVP