vba_excel προβλημα

costasdol — Sun, 19 Apr 2015 19:28:54 GMT

Καλημερα,

Εδω και πολυ καιρο ψαχνω να βρω μια λυση σε ενα πλανο για διαχειριση δωματιων σε γραφικο περιβαλλον. Τελικα βρηκα μια λυση που ταιριαζε με τις δικες μου απαιτησεις και την προσαρμοσα οσο μπορουσα ετσι ωστε να εχω φτασει ενα σκαλακι πριν το τελος.
Εδω λοιπον αδυνατω ειτε να σκεφτω ειτε να βρω λυση ωστε να τροποποιησω τον κωδικα ωστε να μου δωσει το επιθυμητο αποτελεσμα

Να εξηγησω λιγο. Οπως θα δειτε στο επισηναπτομενο αρχειο το συστημα δουλευει με δυο φυλλα εργασιας. Το πρωτο φυλλο ειναι το γραφικο πλανο των δωματιων οπου απικονειζονται τα δωματια και οι ημερομηνιες. Οπου εχουμε κρατηση το συστημα τι χρωματιζει αναλογα με το χρωμα του πελατη (γραφειου) και αναφερει τον πελατη - τον διαμενοντα - το reference - ποσες νυχτες

Οταν κανουμε μια καινουργια κρατηση μου φερνει την πρωτη μερα (ημερα αφιξης) και την χρωματιζει με το επιθυμητο χρωμα
Αυτο που ζηταω ειναι να χρωματιζει ολη την περιοδο διαμονης

Σας παραθετω τον κωδικα. Μπορει καποιος -α να μου κανει μια υποδειξη πως να προχωρησω?

Sub Bookings()

Dim Rm As Range, Dt As Range, myrng As Range, Staff As Range
Dim endCol As Range, StCol As Range, StRow As Range, endRow As Range
Dim Codei As Range, Col As Range
Dim Dws As Worksheet, Cws As Worksheet
Dim x As Integer
Dim LastRow As Long
Dim aCell As Range, bCell As Range, dCell As Range

Set Cws = Sheet1
Set Dws = Sheet2
Set StCol = Cws.Range("I5")
Set endCol = Cws.Range("K5")
Set StRow = Cws.Range("M5")
Set endRow = Cws.Range("O5")

LastRow = Dws.Range("C" & Rows.Count).End(xlUp).Row
Set myrng = Dws.Range("C7:C" & LastRow) 'data sheet columns
Cws.Range("G12:AH81").ClearContents
Cws.Range("G12:AH81").Interior.ColorIndex = xlNone

For x = StRow To endRow
Set Staff = Cws.Cells(x, 6)

For Each dCell In Cws.Range(Cells(x, StCol), Cells(x, endCol))
If Not dCell Is Nothing Then
Set Dt = Cells(11, dCell.Column)

Set aCell = myrng.Find(What:=Staff, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell

Do
Set aCell = myrng.FindNext(After:=aCell)
If aCell.Offset(0, 4).Value = Dt.Value Then
Set Codei = aCell.Cells(1, 7)
Set Col = aCell.Cells(1, 4)
Set dur = aCell.Cells(1, 8)
dCell.Value = Codei

Select Case Col
Case Cws.Range("AP9").Value
dCell.Interior.ColorIndex = 3
Case Cws.Range("AP10").Value
dCell.Interior.ColorIndex = 3
Case Cws.Range("AP11").Value
dCell.Interior.ColorIndex = 5
Case Cws.Range("AP12").Value
dCell.Interior.ColorIndex = 6
Case Cws.Range("AP13").Value
dCell.Interior.ColorIndex = 7
Case Cws.Range("AP14").Value
dCell.Interior.ColorIndex = 26
Case Cws.Range("AP15").Value
dCell.Interior.ColorIndex = 15
Case Cws.Range("AP16").Value
dCell.Interior.ColorIndex = 17
Case Cws.Range("AP17").Value
dCell.Interior.ColorIndex = 19
Case Cws.Range("AP18").Value
dCell.Interior.ColorIndex = 20
Case Cws.Range("AP19").Value
dCell.Interior.ColorIndex = 22
Case Cws.Range("AP20").Value
dCell.Interior.ColorIndex = 24
Case Cws.Range("AP21").Value
dCell.Interior.ColorIndex = 33
Case Cws.Range("AP22").Value
dCell.Interior.ColorIndex = 34
Case Cws.Range("AP23").Value
dCell.Interior.ColorIndex = 35
Case Cws.Range("AP24").Value
dCell.Interior.ColorIndex = 36
Case Cws.Range("AP25").Value
dCell.Interior.ColorIndex = 37
Case Cws.Range("AP26").Value
dCell.Interior.ColorIndex = 38
Case Cws.Range("AP27").Value
dCell.Interior.ColorIndex = 39
Case Cws.Range("AP28").Value
dCell.Interior.ColorIndex = 40
Case Cws.Range("AP29").Value
dCell.Interior.ColorIndex = 41
Case Cws.Range("AP30").Value
dCell.Interior.ColorIndex = 42
Case Cws.Range("AP31").Value
dCell.Interior.ColorIndex = 43
Case Cws.Range("AP32").Value
dCell.Interior.ColorIndex = 8
Case Cws.Range("AP33").Value
dCell.Interior.ColorIndex = 28
Case Cws.Range("AP34").Value
dCell.Interior.ColorIndex = 46
Case Cws.Range("AP35").Value
dCell.Interior.ColorIndex = 14
Case Cws.Range("AP36").Value
dCell.Interior.ColorIndex = 30
Case Cws.Range("AP37").Value
dCell.Interior.ColorIndex = 18
Case Cws.Range("AP38").Value
dCell.Interior.ColorIndex = 4
Case Cws.Range("AP39").Value
dCell.Interior.ColorIndex = 44
Case Cws.Range("AP40").Value
dCell.Interior.ColorIndex = 45
End Select
End If
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Else
Exit Do
End If
Loop

End If
End If
Next dCell

Next

On Error GoTo 0
End Sub

Office Development

vba_excel προβλημα