Long time reader, first time poster...
Using Excel 2013 Professional on a Windows PC.
I have an Excel file with multiple sheets - each sheet is designed for individuals to make their own unique entries across a row and each row represents a complete entry. All the sheets in the workbook have identical columns.
I'm trying to create a Master Worksheet within the same file that captures entries from each of the other sheets as a live worksheet change event --- so when someone adds an entry to their individual sheet it adds the cell addresses for that row to the Master Sheet, and if they delete it, the row in the Master Sheet is cleared.
I have a WorkSheet change event code that does exactly that, the problem is that it only works for one sheet at a time. Using the same code in a different person's sheet only adds/clears the cell addresses to/from the Master Sheet if the entry is in a row that isn't the same as any other sheet (likely due to the "intersect" coding).
Is there a way to achieve this either using a variation of this current code or is there another better way to solve this.
File is attached and here's the code:
- The Master Sheet is called the "Dashboard" (Sheet3)
- "Rep sheet" is the individual person's sheet (ActiveSheet)
- Column "C" in each worksheet is the trigger for adding/subtracting a new entry
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' Adds/subtracts cell addresses of sales reps new entries to the "Dashboard" automatically
' Based on the contents of the "Client" cell
Dim EmptyRow As Long
Dim ClientName As String
Dim FoundEntry As Range
Dim SearchRange
ClientName = "='" & ActiveSheet.Name & "'!" & Target.Cells.Address
' Sales rep sheet - "Client" cell: If entry is cleared, then the row of linked cells on the "Dashboard" are cleared.
If Target.Value = vbNullString Then GoTo ClearEntry
On Error GoTo 0
' Sales rep sheet - "Client" cell: Current entry revised = Don't add new entry or change anything because cells are already linked in Datasheet:
Set SearchRange = Sheet3.Range("C7:C2000")
Set FoundEntry = SearchRange.Find(What:=Target.Address, LookIn:=xlFormulas)
Do
If Not FoundEntry Is Nothing Then Exit Sub
Loop While Not FoundEntry Is Nothing
With ActiveSheet
' Sales rep sheet - "Client" cell: New entry added = add cell links to "Dashboard" sheet for entire entry row:
If Not Intersect(Target, ActiveSheet.Range("$C$7:$C$1000")) Is Nothing And Target.Count = 1 Then
Application.EnableEvents = False
' Finds next empty row in "Dashboard" sheet
'EmptyRow = Range("C65536").End(xlUp) '.Offset(1, 0).Row
' Copies the cell addresses of the row entry to the "Dashboard"
'Sheet3.Range("C65536").End (xlUp)
With Sheet3.Range("C65536").End(xlUp)
' Date
Sheet3.Range("C65536").End(xlUp).Offset(1, -2) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, -2).Address
' Rep
.Offset(1, -1) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, -1).Address
' Client name
.Offset(1, 0) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 0).Address
' New?
.Offset(1, 1) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 1).Address
' Bid?
.Offset(1, 2) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 2).Address
' Project description?
.Offset(1, 3) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 3).Address
' Location?
.Offset(1, 4) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 4).Address
' Award Date?
.Offset(1, 5) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 5).Address
' Start Date
.Offset(1, 6) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 6).Address
' Est $$
.Offset(1, 7) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 7).Address
' Forecast %
.Offset(1, 8) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 8).Address
' Forecast $
.Offset(1, 9) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 9).Address
' ENG hours
.Offset(1, 10) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 10).Address
' PM hours
.Offset(1, 11) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 11).Address
' Install hours
.Offset(1, 12) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 12).Address
' Program hours
.Offset(1, 13) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 13).Address
' Svc contract
.Offset(1, 14) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 14).Address
' Lost/dead
.Offset(1, 15) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 15).Address
' Reason lost/dead
.Offset(1, 16) = "='" & ActiveSheet.Name & "'!" & Target.Cells.Offset(0, 16).Address
End With
Application.EnableEvents = True
Else
ClearEntry:
Set SearchRange = Sheet3.Columns("C:C")
Do
Set FoundEntry = SearchRange.Find(What:=ClientName, LookIn:=xlFormulas)
If Not FoundEntry Is Nothing Then FoundEntry.EntireRow.ClearContents
'If Not FoundEntry.Value = 0 Then FoundEntry.EntireRow.ClearContents
Loop While Not FoundEntry Is Nothing
End If
End With
End Sub
Any help is greatly appreciated.
