How to VBA duplicate values per column with various row ranges for many columns

[Tom-Ronny]

Hi,

I have a challenge related to a excel sheet we are using for personnel planning.

Vertically we have several projects with action items listed row by row in the following format:
- Project 1 xxxxxx
Project management
Project Engineering
Workshop
Shipping
Etc.
- Project 2 xxxxxx
Project management
Project Engineering
Workshop
Shipping
Etc.

Horisontaly on the columns we have dates, day by day for a year +

For each day we chose from a drop down who is assigned to the action item. The problem is when there are 30-40 + projects and each have 20-30 lines of ation items it is hard to get the overview and avoid double entry. I would use conditional formating to do this, but firstly each project is separated by a line containing different formulas and I would not like the conditional formation to change these cells, and at the same time to put this up manually for each row would take a long time since there are 365 + rows.

Any idea to how a VBA code could solve this little challenge? IT would also be beneficial to have it do the check upon cell change, that way we would not need to manually run the VBA to check.


Thankfull for any help on this!

 

[jsotola]

how many action items can be assigned to one person at any one time?

each project should have the same number of rows, maybe 30,
and if a project requires less, then hide rows

you could use a button with a macro to hide blank rows

you could then define a base range, for example, rng = range("a20", "a50", "a80", "a110", "a140" ......... )

this range could point to all the cells containing text "Project Management"

then you would use rng.offset(actionItem , timeSlot) to select all identical action items in a particular time slot

then you would check for duplicates in that time slot

use for each command to loop through the cells in the range

for each cel in rng.offset(actionItem , timeSlot) ............... next cel

of course the range could cover any number of cells in a particular timeslot

rng = range("a20:a40", "a50:a70", "a80:a100", .......... )

 

[Tom-Ronny]

jsotola,

The action items are basically the same but could vary slightly per project. the key beeing that when one chose a name to appoint to the action item from drop down lists in the action item - date cross the VBA code should look at all values in that spesific column for duplicates. if the chosen value exists already it should give the cell a red background.

I have tried this via using the record macro function, but hte two challenges are a. when there are lines separating the projects containing formulas that crashes the code, and b. I am having struggles to have the code do the check in a spesific column when a cell in that column (via drop down list) is changed.

Did that help in clarifying the challenge?

how many action items can be assigned to one person at any one time?

each project should have the same number of rows, maybe 30,
and if a project requires less, then hide rows

you could use a button with a macro to hide blank rows

you could then define a base range, for example, rng = range("a20", "a50", "a80", "a110", "a140" ......... )

this range could point to all the cells containing text "Project Management"

then you would use rng.offset(actionItem , timeSlot) to select all identical action items in a particular time slot

then you would check for duplicates in that time slot

use for each command to loop through the cells in the range

for each cel in rng.offset(actionItem , timeSlot) ............... next cel

of course the range could cover any number of cells in a particular timeslot

rng = range("a20:a40", "a50:a70", "a80:a100", .......... )

 

[Tom-Ronny]

I have a simple macro that does the trix, but the challenge as you may see is taht it only affects one column. How could I get this set up loop through and set the rule for each column at a time from column T to NT (365 days)? I have done some tries, but my challenge is to put up a code changing the T below to next column and so on.

Anyone have any idea?

Sub Macro1()
Range("T5:T33,T35:T63,T65:T93,T95:T123,T125:T153,T155:T183,T185:T213,T215:T243,T245:T273,T275:T303,T305:T333,T335:T363,T365:T393,T395:T423,T425:T453,T455:T483,T485:T513,T516,T515:T543,T545:T573,T575:T603,T605:T633,T635:T663,T665:T693,T695:T723,T725:T753").Select
Range("T725").Activate

Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetLastPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

End Sub

 

[Tom-Ronny]

All,

I have found a code that does what I need it to do, there is only one problem, this is static and only looks as a named range of data and operates on this. How could I rewrite the following code to look at the column I am currently changing (giving a value), and run the code and coloring on this column (maybe from active cell function? ). There will be approx. 365 active columns on the completed sheet, but I do not need the code to run on all at the same time, there will be only one active cell at the time and the code could then just check the active column for duplicates. Any ideas or suggestions?

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngColor As Range
Dim rngToColor As Range
Dim CounterColors As Integer
Dim Counter As Integer
Dim rngColumn As Range
Dim rngDataFilled As Range
' cells with colors to choose from
Set rngColor = wksColor.Range("rngColorStart").Resize(wksColor.Range("SetColor").Value, 1)
' cells with data to be "colored"
Set rngToColor = wksData.Range(Range("rngDataStart"), Cells(65535, Range("rngDataStart").Column).End(xlUp))
' column with data
Set rngColumn = Columns("B")
With wksData
Set rngDataFilled = .Range(.Range("rngDataStart"), .Range("rngDataStart").Offset(10000).End(xlUp))
End With
If Not Intersect(Target, rngColumn) Is Nothing Then
Application.ScreenUpdating = False '
' Let's clear the whole data area (set background color to default)
rngDataFilled.Resize(rngDataFilled.Count + 1).Interior.ColorIndex = _
wksColor.Range("rngDefaultBackground").Interior.ColorIndex
CounterColors = 1 ' color counter reset
With rngToColor
' first cell
If Application.WorksheetFunction.CountIf(rngToColor, .Cells(1).Value) > 1 Then
.Cells(1).Interior.ColorIndex = rngColor.Cells(CounterColors).Interior.ColorIndex
CounterColors = CounterColors + 1
If CounterColors > rngColor.Count Then CounterColors = 1
End If

'more than one cell
If rngDataFilled.Count > 1 Then
' for following cells
For Counter = 2 To .Count
If Application.WorksheetFunction.CountIf(rngToColor, _
.Cells(Counter).Value) > 1 Then
If Application.WorksheetFunction.CountIf(Range("rngDataStart").Resize(Counter - 1), .Cells(Counter).Value) > 0 Then
.Cells(Counter).Interior.ColorIndex = _
rngDataFilled.Find(what:=.Cells(Counter).Value, after:=.Cells(Counter), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex
Else
.Cells(Counter).Interior.ColorIndex = rngColor.Cells(CounterColors).Interior.ColorIndex
CounterColors = CounterColors + 1
If CounterColors > rngColor.Count Then CounterColors = 1
End If
End If
Next Counter
End If
End With
Application.ScreenUpdating = True
End If

End Sub