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

Kocabas3534 · 22 Ocak 2020

Merhaba,

A1 hücresinde yazdığım bir yazının rengini yeşil yaptığımda, B1 hücresine yeşil zemin ile yazmasını nasıl sağlarım.

Örneğn :

A1 hücresi : XXXX FİRMA ADI ( Metni yeşil yaptığımda ) - B1 hücresi : XXXX FİRMA ADI ( hücresine yeşil dolgu ile aynı metin yazacak )

Teşekkürler.

Necdet · 22 Ocak 2020

Merhaba,

Soruyu çok mantıklı bulamadım ama sizce bir mantığı vardır sanırım.
ben olsam A1 hücresini biçimlendirirken B1 hücresini de seçer biçimlendirmeyi öyle yaparım.

Excelde renk değişikliğini anlamak olası mı tam olarak bilmiyorum. Ama isterseniz A sütununda yapılan bir değişiklik (değer) sonucu biçimini B sütununda otomatik yapılabilinir.

Sizce de uygunsa bu kod geliştirilebilinir.

Kocabas3534 · 22 Ocak 2020

Necdet' Alıntı:
Merhaba,

Soruyu çok mantıklı bulamadım ama sizce bir mantığı vardır sanırım.
ben olsam A1 hücresini biçimlendirirken B1 hücresini de seçer biçimlendirmeyi öyle yaparım.

Excelde renk değişikliğini anlamak olası mı tam olarak bilmiyorum. Ama isterseniz A sütununda yapılan bir değişiklik (değer) sonucu biçimini B sütununda otomatik yapılabilinir.

Sizce de uygunsa bu kod geliştirilebilinir.

Necdet bey, dönüşünüz için teşekkürler.

Excel e tam hakim değilim. Fakat sizin önerdiğiniz çözümde işimi görür. Buna göre kod ne olmalıdır.

Desteğiniz için şimdiden teşekkürler.

Necdet · 22 Ocak 2020

Merhaba,

Aşağıdaki kodu tam olarak beğenmemekle birlikte fikir vermesi açısından ekliyorum.
A sütununda herhangi bir hücreye çift tıkladığınızda o hücrenin biçimini hemen yanındaki B sütunundaki hücreye kopyalar.

Kodlar ilgili sayfanın kod bölümüne kopyalayınız.

Kod:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Intersect(Target, [A:A]) Is Nothing Or Target.Value = "" Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .CutCopyMode = False
    End With
    
    Target.Copy
    Target.Offset(0, 1).Select
    Selection.PasteSpecial Paste:=xlPasteFormats
    Target.Activate
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .CutCopyMode = True
    End With
    
End Sub

Kocabas3534 · 23 Ocak 2020

Necdet' Alıntı:
Merhaba,

Aşağıdaki kodu tam olarak beğenmemekle birlikte fikir vermesi açısından ekliyorum.
A sütununda herhangi bir hücreye çift tıkladığınızda o hücrenin biçimini hemen yanındaki B sütunundaki hücreye kopyalar.

Kodlar ilgili sayfanın kod bölümüne kopyalayınız.

Kod:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, [A:A]) Is Nothing Or Target.Value = "" Then Exit Sub With Application .EnableEvents = False .ScreenUpdating = False .CutCopyMode = False End With Target.Copy Target.Offset(0, 1).Select Selection.PasteSpecial Paste:=xlPasteFormats Target.Activate With Application .EnableEvents = True .ScreenUpdating = True .CutCopyMode = True End With End Sub

Necdet bey,

Desteğınız ıçın teşekkurler.
Kısmı olarak ışımı çözdü.

Fakat şımdı başka bir sorum olacak.

Seçmiş olduğum bir sutünda örneğin A2:A30 arası dolu olan hücreleri saydırmak ıstıyorum. Fakat EĞERSAY kullandığımda ıçınde formül olanları da saydığı ıçın tamamını dolu olarak görüyor ve 28 sonucu veriyor. Fakat bu 28 hücrede sadece 3 un de sayı var ve bana sonucu 3 olarak vermesi lazım.

Bunu nasıl yapabılırım.

Teşekkürler.

YUSUF44 · 23 Ocak 2020

Kocabas3534' Alıntı:
Necdet bey,

Desteğınız ıçın teşekkurler.
Kısmı olarak ışımı çözdü.

Fakat şımdı başka bir sorum olacak.

Seçmiş olduğum bir sutünda örneğin A2:A30 arası dolu olan hücreleri saydırmak ıstıyorum. Fakat EĞERSAY kullandığımda ıçınde formül olanları da saydığı ıçın tamamını dolu olarak görüyor ve 28 sonucu veriyor. Fakat bu 28 hücrede sadece 3 un de sayı var ve bana sonucu 3 olarak vermesi lazım.

Bunu nasıl yapabılırım.

Teşekkürler.

BAĞ_DEĞ_SAY formülünü denediniz mi? Bu formül olmuyorsa verilerinizin niteliğini/biçimini vs görmemiz açısından örnek dosya paylaşmanız iyi olur.

Kocabas3534 · 23 Ocak 2020

YUSUF44' Alıntı:
BAĞ_DEĞ_SAY formülünü denediniz mi? Bu formül olmuyorsa verilerinizin niteliğini/biçimini vs görmemiz açısından örnek dosya paylaşmanız iyi olur.

Yusuf bey bu da oldu, çok teşekkürler.

Şımdı çalışmamda en son nokta olan takvim de ılgılı alana seçılı alandaki verıyı aktarma.

Yapmış olduğum çalışma lınkını paylaşıyorum.

Burada takvime, aşağıdaki ış lıstesındekı onaylı olan firmanın adını yanından tarhını seçtığımde otomatik olarak takvime seçtığım güne firma ısmını yazması. yine takvimde aynı şekilde takıp seçtığımde onuda tavkıme yazması. Aynı güne denk gelen işlerde ise alt alta devam etmesi.

Bu ıkı verıyı yazarken onaylı olanlar Yeşil zemin dolgusu ile takıptekıler ise gri zemin dolgusu ile yazmasıdır.

Bu mümkün müdür.

Şımdıden çok teşekkürler.

Aylık İş Takvimi 2020 - Makro.xlsm

drive.google.com

YUSUF44 · 24 Ocak 2020

Aşağıdaki kodları Şubat 2020 sayfasının kod bölümüne kopyalayıp deneyiniz:

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 Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) * 1 = Target * 1 Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = "" Then
                                Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                If Target.Offset(0, -2) = "TAKİP" Then
                                    Cells(i, sut).Interior.ThemeColor = xlThemeColorAccent3
                                ElseIf Target.Offset(0, -2) = "ONAY" Then
                                    Cells(i, sut).Interior.Color = 5287936
                                Else
                                    Cells(i, sut).Interior.Color = xlNone
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                    End If
                End If
            Next
        Next
    End If
End Sub

YUSUF44 · 24 Ocak 2020

Aşağıdaki kodları kullanırsanız J:Q aralığında formül kullanmanız gerekmez:

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 Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) * 1 = Target * 1 Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = "" Then
                                Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                If Target.Offset(0, -2) = "TAKİP" Then
                                    Cells(i, sut).Interior.ThemeColor = xlThemeColorAccent3
                                    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)
                                Else
                                    Cells(i, sut).Interior.Color = xlNone
                                    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
                    End If
                End If
            Next
        Next
    End If
End Sub

Kocabas3534 · 24 Ocak 2020

YUSUF44' Alıntı:

Aşağıdaki kodları Şubat 2020 sayfasının kod bölümüne kopyalayıp deneyiniz:

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 Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) * 1 = Target * 1 Then
                        For i = sat + 2 To sat + 6
                            If Cells(i, sut) = "" Then
                                Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                If Target.Offset(0, -2) = "TAKİP" Then
                                    Cells(i, sut).Interior.ThemeColor = xlThemeColorAccent3
                                ElseIf Target.Offset(0, -2) = "ONAY" Then
                                    Cells(i, sut).Interior.Color = 5287936
                                Else
                                    Cells(i, sut).Interior.Color = xlNone
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                    End If
                End If
            Next
        Next
    End If
End Sub

Yusuf bey,

Desteğiniz ıcın gerçekten çok teşekkürler.

Şu anda tam ıstedığım gıbı bir noktaya geleme semde. Istedığım şeye ulaştım. Bundan sonra bir kaç gelıtırıcı detay ekler isem 10 numara 5 yıldız olacak. Gerçekten çok teşekkürler.

Ben de hemen gold üyelik statüsüne geçiyorum. Gerek emeklerınızden ötürü. Gerekse gerçekten bana ve ışıme çok fazla katma değer sağladığınızdan ötürü.

Emeklerınız ıcın tekrar çok teşekkürler.

Kocabas3534 · 24 Ocak 2020

Kocabas3534' Alıntı:
Yusuf bey,

Desteğiniz ıcın gerçekten çok teşekkürler.

Şu anda tam ıstedığım gıbı bir noktaya geleme semde. Istedığım şeye ulaştım. Bundan sonra bir kaç gelıtırıcı detay ekler isem 10 numara 5 yıldız olacak. Gerçekten çok teşekkürler.

Ben de hemen gold üyelik statüsüne geçiyorum. Gerek emeklerınızden ötürü. Gerekse gerçekten bana ve ışıme çok fazla katma değer sağladığınızdan ötürü.

Emeklerınız ıcın tekrar çok teşekkürler.

Sizden bir kaç revize rica edeceğim.

Yine aynı çalışmada aylık takvime yazdığımız onaylı işler otomatik olarak gelsin onda sorunum yok. Fakat Takipteki işlerimi aylık takvime yazmasın.
Günlük alanda satırım az olduğu için çabuk doluyor. Takıp i yazma olayını kaldıralım.

Birde onaylı işte aylık takvime otomatik yazdırıyoruz. Onda sorun yok. Onaylı işin tarihini değiştirdiğimde değiştirdiğim ilgili güne gerekli yazım otomatik oluyor. Fakat eski tarihte aynı yerde görünmeye devam ediyor. Onaylı işin tarihini değiştirdiğimde eski tarihin otomatik olarak silinmesi gerekmektedir.

Birde ben bu uygulamamızı Mart, Nisan ... gibi diğer aylarda da yapacağım o zaman sayfayı çoğaltarak, Şubat 2020 yi Mart 2020 yaptığımda ve Aylık takvimi de Mart 2020 ye göre düzenlediğim de kod da değişiklik yapmamız gerekecek mı?

YUSUF44 · 24 Ocak 2020

Takipteki işlerin de zemini gri olsun diye belirttiğiniz için o düzenlemeyi yapmıştım.Takipler yazılmayacaksa kod şöyle oluyor:

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 Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) * 1 = Target * 1 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) & " - " & Target.Offset(0, -2)
                                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)
                                    Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                    End If
                End If
            Next
        Next
    End If
End Sub

Tarih değişikliğini nasıl çözerim bilemedim.

Sayfa kopyalamada kodlar da aynen aktarılır(tabi sayfayı taşı ve kopyala yöntemiyle yaparsanız). Kod 2. satırla 34. satır arasındaki tarih olan hücreleri kontrol etmektedir. Bu düzeni değiştirmediğiniz müddetçe sıkıntı çıkmaz.

Kocabas3534 · 24 Ocak 2020

YUSUF44' Alıntı:

Takipteki işlerin de zemini gri olsun diye belirttiğiniz için o düzenlemeyi yapmıştım.Takipler yazılmayacaksa kod şöyle oluyor:

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 Exit Sub
    If Selection.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If IsDate(Target) = True Then
        For sat = 2 To 34 Step 8
            For sut = 2 To 8
                If IsDate(Cells(sat, sut)) = True Then
                    If Cells(sat, sut) * 1 = Target * 1 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) & " - " & Target.Offset(0, -2)
                                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)
                                    Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                    End If
                End If
            Next
        Next
    End If
End Sub

Tarih değişikliğini nasıl çözerim bilemedim.

Sayfa kopyalamada kodlar da aynen aktarılır(tabi sayfayı taşı ve kopyala yöntemiyle yaparsanız). Kod 2. satırla 34. satır arasındaki tarih olan hücreleri kontrol etmektedir. Bu düzeni değiştirmediğiniz müddetçe sıkıntı çıkmaz.

Yusuf bey,

Evet takıp kısmını ben talep etmiştim. Yeni kodda iptal etmişsiniz. Bu kısım tamamdır.

Yeni kodda yine tarh değişikliği yaptığımda eski tarihte yine ıs yazılı kalıyor.

Birde sağda özet listede bir sıkıntı oluştu şimdi. İşlerde tarih değişikliği yaptığımda listenin altına tekrar yazıyor. Bu durum bu son yazdığımız koddan sonra oldu.

Çalışmayı paylaşıyorum.

YUSUF44 · 24 Ocak 2020

O işlemin nasıl yapılacağını çözemediğimi önceki mesajımda belirtmiştim.

Kod D 43'ten itibaren hücreyi her değiştirdiğinizde kontrol eder ve tarih uyuyorsa altına firma yazar, J sütununa da yeni kayıt olarak ekler.

Değişiklik olduğunda ilgili kayıtların da değişmesini sağlamak benim bilgimle kolay değil maalesef. kodun bu halini uydurmak zor olabilir. Kodu hücre değişikliğine değil de düğmeyle çalışacak şekilde ayarlamak gerekebilir.

Kocabas3534 · 24 Ocak 2020

YUSUF44' Alıntı:
O işlemin nasıl yapılacağını çözemediğimi önceki mesajımda belirtmiştim.

Kod D 43'ten itibaren hücreyi her değiştirdiğinizde kontrol eder ve tarih uyuyorsa altına firma yazar, J sütununa da yeni kayıt olarak ekler.

Değişiklik olduğunda ilgili kayıtların da değişmesini sağlamak benim bilgimle kolay değil maalesef. kodun bu halini uydurmak zor olabilir. Kodu hücre değişikliğine değil de düğmeyle çalışacak şekilde ayarlamak gerekebilir.

Pekı, Yusuf bey.

Sızın önerınıze göre çalışmamı düzenleyıp bana atabıır mısınız.

YUSUF44 · 24 Ocak 2020

Eski kodları iptal edip şu kodları dener misiniz?

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 Exit Sub
    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] & " - " & [S2] 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 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) & " - " & Target.Offset(0, -2)
                            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)
                                Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                            End If
                            i = sat + 6
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    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 Exit Sub
    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
End Sub

Kocabas3534 · 24 Ocak 2020

YUSUF44' Alıntı:

Eski kodları iptal edip şu kodları dener misiniz?

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 Exit Sub
    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] & " - " & [S2] 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 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) & " - " & Target.Offset(0, -2)
                            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)
                                Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                            End If
                            i = sat + 6
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    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 Exit Sub
    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
End Sub

Denedim, Yusuf bey.. İlk olarak takvimde ilgili güne işleri yazarken yeni ışı bir alt satıra değilde ilgili günün ilk satırında başka bir iş yazmasına rağmen. Yine birinci satıra yazmakta.
Gün değişikliği yaptığımda yine eski yerde ıs görünmekte.

YUSUF44 · 24 Ocak 2020

Aşağıdaki gibi 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 Exit Sub
    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] & " - " & [S2] 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) & " - " & Target.Offset(0, -2)
                                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)
                                    Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    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 Exit Sub
    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
End Sub

Kocabas3534 · 24 Ocak 2020

YUSUF44' Alıntı:

Aşağıdaki gibi 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 Exit Sub
    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] & " - " & [S2] 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) & " - " & Target.Offset(0, -2)
                                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)
                                    Cells(i, sut) = Target.Offset(0, -1) & " - " & Target.Offset(0, -2)
                                End If
                                i = sat + 6
                            End If
                        Next
                        sut = 8
                        sat = 34
                        [S2:U2].ClearContents
                    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 Exit Sub
    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
End Sub

Desteğiniz için teşekkürler, Yusuf bey.

Sızı uğraştırıyor um.

Şimdi ki kodda tarih değişikliğin de, eski yerdeki firma adını siliyor. Bu süper oldu.

Bir iki değişiklik daha rica edeceğim mümkün ise.

- takvimde onaylı işi yazdığımızda firma ismi yanında - işretin den sonra onay yazmasın. Sadece firma ismi yeterlidir.
- yine takvimde onaylı olan bir işi tekrar takip veya olumsuza aldığımda, firmanın ismi takvimde görünmesin.

YUSUF44 · 24 Ocak 2020

Olumsuz olanlar hiçbir şekilde takvimde görünmeyecek mi, takvimde sadece onaylılar mı görünecek?

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

Kocabas3534

Necdet

Moderatör

Kocabas3534

Necdet

Moderatör

Kocabas3534

YUSUF44

Destek Ekibi

Kocabas3534

Aylık İş Takvimi 2020 - Makro.xlsm

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

Kocabas3534

Kocabas3534

YUSUF44

Destek Ekibi

Kocabas3534

Ekli dosyalar

YUSUF44

Destek Ekibi

Kocabas3534

YUSUF44

Destek Ekibi

Kocabas3534

YUSUF44

Destek Ekibi

Kocabas3534

YUSUF44

Destek Ekibi