PDA

View Full Version : need a code.....



foxbat
04-22-2009, 08:20 PM
Hi


I’ve just started to use vba and think it will be able to help me. I’ve just been sent somewhere new (and of course didn’t bring my vba book with me) with my job for a few months. Since being here I think a small code may make my job so much easier as i’m doing it all by hand and checking at the minute.
I’m using excel 2003. I think I need 4 fields e.g


field1 field2 field3 field4


sw ci 14 18
sl ck 19 21


I need to know if should I allocate a job to new employee the same location – field 2 – and a confliction happens on the job no range – fields 2 & 3- inclusive then the confliction to highlight maybe by changing colour.
For example if I now allocated ‘cw’ location ci and job no’s 15 and 16 then there is a confliction with sw as he has been allocated 14 to 18. I appreciate it looks easy with just the 2 on the list but I can have up to fifty or more and the tasking needs to be dynamic.
Any help would be greatly appreciated.
Thanks very much for your time.

GTO
04-23-2009, 04:12 AM
I need to know if should I allocate a job to new employee the same location – field 2 – and a confliction happens on the job no range – fields 2 & 3- inclusive then the confliction to highlight maybe by changing colour.

Greetings foxbat,

Eh?

Maybe just me, but I am not getting what you are trying to do. Could you attach an example workbook? No company/private info, but enough that we could see expected data and what (maybe a description) is supposed (desired) to happen should a "conflict" occur.

Hope to help,

Mark

mdmackillop
04-23-2009, 10:49 AM
Could you use conditional formatting?
=COUNTIF(A:A,A1)>1
Will highlight duplicate entries in that column.

foxbat
04-23-2009, 11:03 AM
Hi Mark

Thanks for the reply, no its me i re-read what i'd posted and it doesn't make a lot of sense though it did at 5 in the morning when i typed it before work!
Hopefully the spreadsheet will bring more clarity. I appreciate its an openoffice doc but i'm running linux on my laptop that i've brought with me it should open ok in excel. Its windows and excel 2003 at work.
Thanks for your time and hopefully you can help as i work in an ops centre, the work can come flying in and i've got a laminated sheet in front of me with a water soluble pen to keep track.
Again any help is greatly appreciated,
Steve

foxbat
04-23-2009, 11:10 AM
Thanks mdmack,

Its about 40 to 50 rows. I'm just trying to attach a spraedsheet but failed in my previous post, i'm trying again now.
As i said i'm an absolute newb who only started about a month ago, my some total of programming so far is a simple 'if' one that counted and added lots of rows if certain parameters were true. I just got sent on this job and saw what the guys were using and thought there must be a more efficient way of working
I'll try this attachment again.
Thanks

foxbat
04-23-2009, 11:17 AM
I can't upload an ods file and i haven't made enough posts to create a link so i will try and post one from a work computer tomorrow.
Thanks guys.

mdmackillop
04-23-2009, 11:35 AM
Try zipping it first.

foxbat
04-23-2009, 07:27 PM
file:///tmp/moz-screenshot.jpg

i've tried to attach a screenshot, I'll see if this works.

mdmackillop
04-24-2009, 12:42 AM
Use Manage Attachments to show a jpg

foxbat
04-24-2009, 03:39 AM
I think i've managed to attach an xls file! Sorry for being a biff guys, thanks for your patience.
Hopefully this clears it up. I was thinking of trying to do something like an IF function with =>. But seeing your COUNT it just drove home how sparse my knowledge is. Hopefully I won't be as bad at learning vba as I am at posting in forums!
Thanks

Steve

mdmackillop
04-24-2009, 11:23 AM
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Locat As Range, aFr As Range, aTo As Range, c As Range
Dim FirstAddress As String
Dim Low As Long, High As Long

If Target.Column <= 4 Then
Set Locat = Cells(Target.Row, 2)
Set aFr = Cells(Target.Row, 3)
Set aTo = Cells(Target.Row, 4)
Locat.Resize(, 3).Interior.ColorIndex = xlNone
With Columns(2)
Set c = .Find(Locat, LookIn:=xlValues, After:=Locat)
If Not c Is Nothing Then
FirstAddress = Locat.Address
Do
Low = c.Offset(, 1)
High = c.Offset(, 2)
If aFr >= Low And aFr <= High Then
aFr.Interior.ColorIndex = 6
End If
If aTo >= Low And aTo <= High Then
aTo.Interior.ColorIndex = 6
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End If
End Sub

foxbat
04-24-2009, 09:28 PM
Thanks very much MdMack

Going to input this now, i'll let you know how it goes.

Cheers

Steve

Aussiebear
04-25-2009, 12:16 AM
Hmmm.... Sorry Steve but I can't follow the logic here. You are saying that if you enter fb (new person) at ci a similar location to sw & cw, that sw & cw's allocations overlap, yet when they ci & cw are at the same location, but fb doesn't get allocated, this is fine???

foxbat
04-25-2009, 01:31 AM
Aussie

No I was saying that the locations can be the same as long as the allocations don't conflict, i need to know if i enter a new employee and give an allocation that i have already given out. In the remarks I made please read '....column changing colour or a...'. Hope this clears it up a little for you. I appreciate it looks simple with 4 entries and it is but whan I have 30 or 40 on my board sometimes its easy to makea mistake and my boss is breathing down my neck to give hime the allocation asap.

Aussiebear
04-25-2009, 03:35 AM
Sorry but that is not what is in your workbook

mdmackillop
04-25-2009, 03:53 AM
Why not check availability first? (Assuming I understand what is meant to be happening!)
BTW The info is confusing and data too limited. It is worth making up a realistic example to get things right first time.

foxbat
04-26-2009, 06:58 AM
Hi guys

Sorry Due to download restrictions on my works computers I can't look at the worksheet you've uploaded. Mdmack the code you've already given is almost bang on. The only thing is that the original inputs are turning yellow. Is there any chance that the text could remain black and white until there is a confliction and that box change colour where the confliction occurs just to highlight that i've made a duplication in job allocation.
I'll upload a exact sample of ten of what I had this afternoon and exactly how I allocate location and jobs.
Aussie I sort of see what you're saying but but the second paragragh refers to sw and fb as the confliction illustrates. Perhaps I need to study english instead of vba ha ha.

mdmackillop
04-26-2009, 09:02 AM
Worksheet module code

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo exits
Application.EnableEvents = False


If Target.Column = 2 Then
Locats Target
End If
exits:
Application.EnableEvents = True

End Sub


Standard module code

Sub Locats(Data As Range)
Dim Cel As Range
Dim Loc As String
Loc = Data
i = 8
Max = Application.Max(Range("C:D"))
Range("I:Z").Interior.ColorIndex = xlNone
Range("H:Z").ClearContents
Range("H1") = Data
For Each Cel In Rng("B")
If Cel.Value = Data.Value And Cel.Address <> Data.Address Then
i = i + 1
Cells(1, i) = Cel.Offset(, -1)
With Range(Cells(Cel.Offset(, 1) + 1, i), Cells(Cel.Offset(, 2) + 1, i))
.Interior.ColorIndex = 3
.Value = "x"
End With
End If
Next
For j = 2 To Max
If Application.CountA(Cells(j, 8).Resize(, i)) = 0 Then
Cells(j, 8) = j - 1
End If
Next
End Sub

Function Rng(col) As Range
Set Rng = Range(Cells(2, col), Cells(Rows.Count, col).End(xlUp))
End Function

mdmackillop
04-26-2009, 10:36 AM
A change to the original code as 185/210 would not show in your latest example

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Locat As Range, aFr As Range, aTo As Range, c As Range
Dim FirstAddress As String
Dim Low As Long, High As Long

If Target.Column <= 4 Then
Columns("C:D").Interior.ColorIndex = xlNone
Set Locat = Cells(Target.Row, 2)
Set aFr = Cells(Target.Row, 3)
Set aTo = Cells(Target.Row, 4)

Locat.Resize(, 3).Interior.ColorIndex = xlNone
With Columns(2)
Set c = .Find(Locat, LookIn:=xlValues, After:=Locat)
If Not c Is Nothing Then
FirstAddress = Locat.Address
Do
Low = c.Offset(, 1)
High = c.Offset(, 2)
If aFr >= Low And aFr <= High Then
aFr.Interior.ColorIndex = 6
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If aTo >= Low And aTo <= High Then
aTo.Interior.ColorIndex = 6
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If Low >= aFr And Low <= aTo Then
aFr.Interior.ColorIndex = 35
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If High >= aFr And High <= aTo Then
aTo.Interior.ColorIndex = 35
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End If
End Sub

foxbat
04-26-2009, 08:00 PM
Thanks mdmack, i'll give this a try first chance i get today. I really appreciate this I'm sure i've been frustrating by trying to simplify everything and just not providing needed information.

Steve

foxbat
04-27-2009, 11:53 PM
Thanks mdmack

It works really well. The only small points are that if I enter the name before the area then columns C and D change to yellow all the way down and excel stops responding. The same happens if i delete data from column b/c/d leaving the name in. That is with just the code from above not the stuff above that. If this is not quickly fixable then its not such an issue I'll just work round it. Thanks very much for your help regardless its been really top notch if you would like remuneration then let me know or a donation to vbax or a charity off your choice.
Thanks very much

foxbat
04-29-2009, 02:04 AM
I've tried in the column after (e) as well. Do I need to add a column along with 'locat' 'fr' and 'to'? I could do with a remarks column in addition now i've tried to use it. Anyhelp would be appreciated.

Steve

foxbat
05-04-2009, 05:37 PM
Hi again

Hope i'm not being a pain. I've tried to add code myself but get syntax errors. I've tried work rounds but they eventually fail. This is ideally what i would like the sheet to look like. Its essentially adding two columns for name and remarks that don't send columns c and d scrolling down madly in yellow.Or so that i can add other columns as the need arises without effecting the columns b,c and d which are all important. Sorry to bang on. Hope you can help.
:help

fb

mdmackillop
05-05-2009, 11:23 AM
Hi Steve,
Can you post a "better" sample with realistic layout of data and desired result. A couple of lines is unrealistic to test on.

foxbat
05-05-2009, 04:23 PM
Hi Mdmack

Your earlier code is good apart from the fact that should I input a name (or a remark) and then delete a line in the middle then rows c & d scroll down yellow and excel stops responding.
So I need the extra couple of columns that are just for text while the highlight of 'froms' and 'to's' in same area that overlap continue.
If I can delete lines as they are complete, say ur is finished then i can just delete the line without the scrolling yellow columns c & d.
Thanks very much

Steve

mdmackillop
05-10-2009, 03:04 AM
Give this a try
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Locat As Range, aFr As Range, aTo As Range, c As Range
Dim FirstAddress As String
Dim Low As Long, High As Long

If Target.Column <= 3 Then Columns("C:D").Interior.ColorIndex = xlNone
If Target.Column = 3 Or Target.Column = 4 Then
Columns("C:D").Interior.ColorIndex = xlNone
Set Locat = Cells(Target.Row, 2)
Set aFr = Cells(Target.Row, 3)
Set aTo = Cells(Target.Row, 4)

Locat.Resize(, 3).Interior.ColorIndex = xlNone
With Columns(2)
Set c = .Find(Locat, LookIn:=xlValues, After:=Locat)
If Not c Is Nothing Then
FirstAddress = Locat.Address
Do
Low = c.Offset(, 1)
High = c.Offset(, 2)
If aFr >= Low And aFr <= High Then
aFr.Interior.ColorIndex = 6
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If aTo >= Low And aTo <= High Then
aTo.Interior.ColorIndex = 6
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If Low >= aFr And Low <= aTo Then
aFr.Interior.ColorIndex = 35
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If
If High >= aFr And High <= aTo Then
aTo.Interior.ColorIndex = 35
c.Offset(, 1).Resize(, 2).Interior.ColorIndex = 6
End If

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End If
End Sub