Zaman dilim Makrosu

[edkaya]

Arkadaşlar / Ustadlar
ekli dosyada açıklamaya çalıştım. bunu formulle yapmak sanırım dosyayı çok fazla şişirir. fakat buna yazılabilecek bir makro varmıdır. ikinci sayfadan yapılan işleri, birinci sayfada yapan kişiye bakarak saat dilimlerini boyamak. yardımlarınızı bekliyorum teşekür ederim.

 

[edkaya]

üstadlarım, yardımlarınızı bekliyorum.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Boya()
Dim i   As Long
Dim c   As Range
Dim d   As Range
Dim BsKol As Integer
Dim BtKol As Integer
Dim s1  As Worksheet
Dim s2  As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s1.Select
Application.ScreenUpdating = False
Range("B4:AX" & [A65536].End(3).Row).Interior.ColorIndex = xlNone
For i = 5 To s2.[B65536].End(3).Row
    Set c = Range("A:A").Find(s2.Cells(i, "B"), LookIn:=xlFormulas)
    If Not c Is Nothing Then
        Set d = Range("2:2").Find(s2.Cells(i, "D"), LookIn:=xlFormulas)
            If Not d Is Nothing Then
                BsKol = (24 * Day(d.Value)) - 24 + Hour(s2.Cells(i, "E")) + 2
                If s2.Cells(i, "F") < s2.Cells(i, "E") Then
                    BtKol = (24 * Day(d.Value)) - 24 + BsKol + (26 - BsKol) + Hour(s2.Cells(i, "F"))
                Else
                    BtKol = (24 * Day(d.Value)) - 24 + BsKol + (Hour(s2.Cells(i, "F")) - BsKol) + 2
                End If
                Range(Cells(c.Row, BsKol), Cells(c.Row, BtKol)).Interior.ColorIndex = 3
            End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Boyadım......", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[edkaya]

hocam elinize sağlık, ama iki sorum olacak
1: boya diye bir button koymadan otomatikleştirebilirmiyiz?
2: boyayınca içine görevlerinide yazması mümkünmüdür?

teşekür ederim.

 

[Necdet]

Merhaba,

Aşağıdaki kodların Sayfa1'in kod bölümünde olmalı.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If Target.Row < 4 Then Exit Sub
Dim s2          As Worksheet
Dim BsKol       As Integer
Dim BtKol       As Integer
Dim c           As Range
Dim d           As Range
Set s2 = Sheets("Sayfa2")
Range("B" & Target.Row & ":IV" & Target.Row).Interior.ColorIndex = xlNone
Set c = s2.Range("B:B").Find(Target.Value, LookIn:=xlValues)
If Not c Is Nothing Then
    Set d = Range("2:2").Find(s2.Cells(c.Row, "D"), LookIn:=xlFormulas)
    If Not d Is Nothing Then
        BsKol = (24 * Day(d.Value)) - 24 + Hour(s2.Cells(c.Row, "E")) + 2
        If s2.Cells(c.Row, "F") < s2.Cells(c.Row, "E") Then
            BtKol = (24 * Day(d.Value)) - 24 + BsKol + (26 - BsKol) + Hour(s2.Cells(c.Row, "F"))
        Else
            BtKol = (24 * Day(d.Value)) - 24 + BsKol + (Hour(s2.Cells(c.Row, "F")) - BsKol) + 2
        End If
        With Range(Cells(Target.Row, BsKol), Cells(Target.Row, BtKol))
            .Interior.ColorIndex = 3
            .Value = s2.Cells(c.Row, "C")
        End With
    End If
End If
Son:
End Sub