data entered on multiple sheets also added to summary sheet

[Guest]

I need to have data entered on different sheets automatically add itself to
the next available row of a summary sheet (I have some code that will enter
the data on another sheet but will not update if original data is edited!! I
can live with this but would be awesome if this were possible!!)

AND

if it is possible to have the new row in the summary sheet shaded based on a
condition, e.g., if cell=name, shade row blue; if cell=name2, shade row
green, etc.
Is this beyond XL ??
Any thoughts would be very much appreciated.
cheers,
Nadia

 

[Guest]

Hi Nadia,

I think more information is needed to create a solution for you. Is the data
entered on the other sheets more than one row? Is it the last row within each
of the added sheets? Is it possible for you to post up the code? Is the data
added to the summary sheet an entire row? Selected cells? Etc.

Yes, it is possible to have the most current row of the summary sheet shaded
based on a condition. Also, do you want ONLY the last ("current") row of the
summary sheet shaded? Or do you want it to keep previous row colors so that
you can see name1 colors, name2 colors, etc.?

Thanks,
James

 

[Guest]

Hi James,

each new record on the other sheets is one row only from A:I and this data
is copied to the summary sheet. The data is entered on the next available row
of the sheets. There are some formulas in the original data and these are
copied across as values.

yes, I would love to keep all conditional shading not just current. The
condition for the shading is actually the sheet name where the original data
is entered, e.g., if sheet name=mid tunnel, shade cells A:J blue; etc.

Here is the code (many thanks Dave Peterson and Gord Dibben):

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim destCell As Range

'one cell at a time only!
If Target.Cells.Count > 1 Then Exit Sub

'only check column J this is the trigger cell to copy
If Intersect(Target, Me.Range("J:J")) Is Nothing Then Exit Sub

'and it can't be empty!
If IsEmpty(Target) Then Exit Sub

'Column A of the row must have data
If IsEmpty(Me.Cells(Target.Row, "A")) Then
MsgBox "Please put something in A" & Target.Row
Exit Sub
End If

With Worksheets("summary")
Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

On Error GoTo errHandler:
Application.EnableEvents = False
Target.EntireRow.Resize(1, 9).Copy
destCell.PasteSpecial Paste:=xlPasteValues
Target.Value = "Copied"
Application.CutCopyMode = False
Beep

errHandler:
Application.EnableEvents = True

End Sub

The only limitation as I mentioned is any changes to the original data will
not update the summary sheet, but I can live with this. The main "wish" is
the conditional shading.

Thank you so much for looking at this.

cheers,
Nadia

 

[Guest]

Hi Nadia,

Add the code below to a module in your workbook. Then add a call to
ShadeSummaryData which will loop through all the rows in the Summary
worksheet and update them with colors.

I would add the "ShadeSummaryData" in your code here:
....
Application.CutCopyMode = False
ShadeSummaryData
Beep
....

I decided to have the code loop through the Summary worksheet in case you
make changes. That way it will always have the correct conditional shading.
Also, note that it is looking in Column A for the conditional value (i.e.,
Nadia, James, etc.). You will need to change that to the correct Column as
needed.

Let me know if you have any questions or problems. Hope that helps.

Cheers,
James

PS - You could have the data on the Summary sheet update when other
worksheet changes are made, but that would probably be a decent chunk of code
to write. Let me know if you're interested though. I'd need a little more
detail on where changes are made and how you'd like it to update. Thanks.

Sub ShadeSummaryData()
' DECLARATIONS
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim intColorIndex As Integer

' INITIALIZE
On Error GoTo ErrHandler
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Summary")

'MAIN BODY
For Each rng In wks.Range("A1:A" & wks.Cells(wks.Cells.Rows.Count,
"A").End(xlUp).Row)
Select Case rng.Value
Case "James"
intColorIndex = 35 ' Light Green
Case "Nadia"
intColorIndex = 36 ' Light Yellow
Case "Dave"
intColorIndex = 37 ' Pale Blue
Case "Gord"
intColorIndex = 40 ' Tan
Case "Susan"
intColorIndex = 38 ' Rose
Case Else
' Set the Color Index to No Color.
intColorIndex = xlNone
End Select
rng.EntireRow.Resize(1, 9).Interior.ColorIndex = intColorIndex
Next rng

MsgBox "The Summary worksheet data has been conditionally shaded."

CleanUp:
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Exit Sub

WrapUp:
GoSub CleanUp
Return

ErrHandler:
MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf &
Err.Description, _
vbOKOnly + vbInformation, "ConditionalShading()"
GoSub WrapUp
End Sub

 

[Guest]

Hi James,
Im getting error message here:

'MAIN BODY
For Each rng In wks.Range("A1:A" & wks.Cells(wks.Cells.Rows.Count,
"A").End(xlUp).Row)

and here:

ErrHandler:

MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf &
Err.Description, _
vbOKOnly + vbInformation, "ConditionalShading()"

Thank you for your help it looks very impressive
cheers,
Nadia

 

[Norman Jones]

Hi Nadia,

For Each rng In wks.Range("A1:A" & wks.Cells(wks.Cells.Rows.Count,
"A").End(xlUp).Row)

Should be one line of code. Long code lines can be broken up with the use of
line continuation characters ( _).

Replace the above by copy / pastining:

For Each rng In wks.Range("A1:A" & wks.Cells(wks.Cells. _
Rows.Count, "A").End(xlUp).Row)

Similarly,

should be a single line of code.

Replace the existing code snippet by copy / pasting:

MsgBox "Error Number: " & Err.Number & vbCrLf _
& vbCrLf & Err.Description, _
vbOKOnly + vbInformation, _
"ConditionalShading()"

 

[Guest]

Hi Norman,

Thanks for the help.

Hi Nadia,

It must have looked (or copied) like two separate lines when I pasted the
code into the Reply window.

Hope it works for you now.

Thanks,
James

 

[Guest]

Thank you Norman and James,
that has fixed the code but it doesnt seem to be working, the data is not
copying and I am getting this error message: ConditionalShading() Error
Number: 9 Subscript out of range

This is what it all looks like - what have I done wrong??

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim destCell As Range

'one cell at a time only!
If Target.Cells.Count > 1 Then Exit Sub

'only check column J
If Intersect(Target, Me.Range("J:J")) Is Nothing Then Exit Sub

'and it can't be empty!
If IsEmpty(Target) Then Exit Sub

'Column A of the row must have data
If IsEmpty(Me.Cells(Target.Row, "A")) Then
MsgBox "Please put something in A" & Target.Row
Exit Sub
End If

With Worksheets("summary")
Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

On Error GoTo ErrHandler:
Application.EnableEvents = False
Target.EntireRow.Resize(1, 9).Copy _
Destination:=destCell
Target.Value = "Copied"
Beep

Application.CutCopyMode = False
ShadeSummaryData
Beep

ErrHandler:
Application.EnableEvents = True


End Sub
Sub ShadeSummaryData()
' DECLARATIONS
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim intColorIndex As Integer

' INITIALIZE
On Error GoTo ErrHandler
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Summary")

'MAIN BODY
For Each rng In wks.Range("A1:A" & wks.Cells(wks.Cells. _
Rows.Count, "A").End(xlUp).Row)

Select Case rng.Value
Case "James"
intColorIndex = 35 ' Light Green
Case "Nadia"
intColorIndex = 36 ' Light Yellow
Case "Dave"
intColorIndex = 37 ' Pale Blue
Case "Gord"
intColorIndex = 40 ' Tan
Case "Susan"
intColorIndex = 38 ' Rose
Case Else
' Set the Color Index to No Color.
intColorIndex = xlNone
End Select
rng.EntireRow.Resize(1, 9).Interior.ColorIndex = intColorIndex
Next rng

MsgBox "The Summary worksheet data has been conditionally shaded."

CleanUp:
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Exit Sub

WrapUp:
GoSub CleanUp
Return

ErrHandler:
MsgBox "Error Number: " & Err.Number & vbCrLf _
& vbCrLf & Err.Description, _
vbOKOnly + vbInformation, _
"ConditionalShading()"

GoSub WrapUp
End Sub


Sorry for being such a pain... I am determined to learn this foreign
language!!!

Thanks again.
Nadia

 

[Guest]

Hi Nadia,

Try changing this piece of code:

Set wks = wkb.Worksheets("Summary")

I think because I have the "S" capitalized it might be causing problems. Try
changing it to all lowercase ("summary") and let me know if that helps.
Otherwise I don't see anything standing out. I'll double check it again.

Thanks,
James

 

[Guest]

Hi James,

Works beautifully

You are worth your weight in gold!!!

BTW do you know the color codes for blue, red and orange?

many many thanks

Nadia ;-)

 

[Guest]

Hi Nadia,

I'm glad that it's working for you! (and thanks)

Here's a link to a website I did a quick ColorIndex search on:

http://www.mvps.org/dmcritchie/excel/colors.htm

Hopefully that will get you all the colors you need.

Cheers,
James