Font rengine göre, başka bir hücreye değer atama

Kocabas3534

Kocabas3534

Katılım
24 Aralık 2019
Mesajlar
13
Excel Vers. ve Dili
Excel 2010, Türkçe
Altın Üyelik Bitiş Tarihi
24-01-2021
YUSUF44' Alıntı:
Olumsuz olanlar hiçbir şekilde takvimde görünmeyecek mi, takvimde sadece onaylılar mı görünecek?
Genişletmek için tıkla ...
Aynen, olumsuz yada takıp olanlar takvimde yer almasın. Onlar sadece takvim yanında, üç sütun var onaylı-takıp-olumsuz diye. Orada ilgili yerlerinde yazılı olacak ve takip edilecek.
Aylık takvim de sadece ilgili günde onaylı işin firma ismi yazması yeterli.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Eski kodları silip aşağıdaki kodları deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("D43:D" & son)) Is Nothing Then GoTo 10
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        If [S2] <> "" Then
            For sat = 2 To 34 Step 8
                For sut = 2 To 8
                    If IsDate(Cells(sat, sut)) = True Then
                        If Cells(sat, sut) = [U2] Then
                            For i = sat + 2 To sat + 6
                                If Cells(i, sut) = [T2] Then
                                    Cells(i, sut).ClearContents
                                    Cells(i, sut).Interior.Color = xlNone
                                End If
                            Next
                        End If
                    End If
                Next
            Next
        End If
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) = Target Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = "" Then
                                If Target.Offset(0, -2) = "TAKİP" Then
                                    yeniM = Cells(Rows.Count, "M").End(3).Row + 1
                                    Cells(yeniM, "M") = yeniM - 1
                                    Cells(yeniM, "N") = Target.Offset(0, -1)
                                ElseIf Target.Offset(0, -2) = "ONAY" Then
                                    Cells(i, sut).Interior.Color = 5287936
                                    yeniJ = Cells(Rows.Count, "J").End(3).Row + 1
                                    Cells(yeniJ, "J") = yeniJ - 1
                                    Cells(yeniJ, "K") = Target.Offset(0, -1)
                                    Cells(i, sut) = Target.Offset(0, -1)
                                ElseIf Target.Offset(0, -2) = "OLUMSUZ" Then
                                    Cells(i, sut).Interior.Color = vbRed
                                    yeniP = Cells(Rows.Count, "P").End(3).Row + 1
                                    Cells(yeniP, "P") = yeniP - 1
                                    Cells(yeniP, "Q") = Target.Offset(0, -1)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    End If
                End If
            Next
        Next
    End If
10:
    If Intersect(Target, Range("B43:B" & son)) Is Nothing Then Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target.Offset(0, 2) = "" Or Target.Offset(0, 1) = "" Or [S3] = "" Then Exit Sub
    If [S3] = "ONAY" Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) = [U3] Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = [T3] Then
                                Cells(i, sut).ClearContents
                                Cells(i, sut).Interior.Color = xlNone
                                [S3:U3].ClearContents
                            End If
                        Next
                    End If
                End If
            Next
        Next
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("D43:D" & son)) Is Nothing Then GoTo 20
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        [S2] = Target.Offset(0, -2)
        [T2] = Target.Offset(0, -1)
        [U2] = Target
    End If
20:
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("B3:B" & son)) Is Nothing Then Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If Target = "ONAY" Then
        [S3] = Target
        [T3] = Target.Offset(0, 1)
        [U3] = Target.Offset(0, 2)
    End If
End Sub
 
Kocabas3534

Kocabas3534

Katılım
24 Aralık 2019
Mesajlar
13
Excel Vers. ve Dili
Excel 2010, Türkçe
Altın Üyelik Bitiş Tarihi
24-01-2021
YUSUF44' Alıntı:
Eski kodları silip aşağıdaki kodları deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("D43:D" & son)) Is Nothing Then GoTo 10
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        If [S2] <> "" Then
            For sat = 2 To 34 Step 8
                For sut = 2 To 8
                    If IsDate(Cells(sat, sut)) = True Then
                        If Cells(sat, sut) = [U2] Then
                            For i = sat + 2 To sat + 6
                                If Cells(i, sut) = [T2] Then
                                    Cells(i, sut).ClearContents
                                    Cells(i, sut).Interior.Color = xlNone
                                End If
                            Next
                        End If
                    End If
                Next
            Next
        End If
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) = Target Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = "" Then
                                If Target.Offset(0, -2) = "TAKİP" Then
                                    yeniM = Cells(Rows.Count, "M").End(3).Row + 1
                                    Cells(yeniM, "M") = yeniM - 1
                                    Cells(yeniM, "N") = Target.Offset(0, -1)
                                ElseIf Target.Offset(0, -2) = "ONAY" Then
                                    Cells(i, sut).Interior.Color = 5287936
                                    yeniJ = Cells(Rows.Count, "J").End(3).Row + 1
                                    Cells(yeniJ, "J") = yeniJ - 1
                                    Cells(yeniJ, "K") = Target.Offset(0, -1)
                                    Cells(i, sut) = Target.Offset(0, -1)
                                ElseIf Target.Offset(0, -2) = "OLUMSUZ" Then
                                    Cells(i, sut).Interior.Color = vbRed
                                    yeniP = Cells(Rows.Count, "P").End(3).Row + 1
                                    Cells(yeniP, "P") = yeniP - 1
                                    Cells(yeniP, "Q") = Target.Offset(0, -1)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    End If
                End If
            Next
        Next
    End If
10:
    If Intersect(Target, Range("B43:B" & son)) Is Nothing Then Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target.Offset(0, 2) = "" Or Target.Offset(0, 1) = "" Or [S3] = "" Then Exit Sub
    If [S3] = "ONAY" Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) = [U3] Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = [T3] Then
                                Cells(i, sut).ClearContents
                                Cells(i, sut).Interior.Color = xlNone
                                [S3:U3].ClearContents
                            End If
                        Next
                    End If
                End If
            Next
        Next
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("D43:D" & son)) Is Nothing Then GoTo 20
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        [S2] = Target.Offset(0, -2)
        [T2] = Target.Offset(0, -1)
        [U2] = Target
    End If
20:
    son = WorksheetFunction.Max(43, Cells(Rows.Count, "B").End(3).Row)
    If Intersect(Target, Range("B3:B" & son)) Is Nothing Then Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If Target = "ONAY" Then
        [S3] = Target
        [T3] = Target.Offset(0, 1)
        [U3] = Target.Offset(0, 2)
    End If
End Sub
Genişletmek için tıkla ...
Yusuf bey,

ELLERİNİZE EMEĞİNİZE SAĞLIK. TAM İSTEDİĞİM GİBİ OLDU. ÇOK TEŞEKKÜRLER.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst