Gantt Diyagramı yardım

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Dosyanızı buna örnek olacak şekilde paylaşır mısınız? Yani hangi durumda silme hangi durumda boyama yapılacak?
 
sosorry

sosorry

Katılım
17 Ocak 2007
Mesajlar
193
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
04-06-2022
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyiniz:

PHP: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        hata = hata + 1
    ElseIf IsDate(Cells(i, "F")) = False Then
        Cells(i, "F").Interior.Color = vbRed
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
End Sub
Genişletmek için tıkla ...
sizin yapmış olduğunuz bu çözüm var ya, işte onda " Sub gannt() " tıkladığımda tarih olanları boyasın ancak tarih olmayanların da seçimlerini silsin.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi dener misiniz?

PHP: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Or IsDate(Cells(i, "F")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        Cells(i, "F").Interior.Color = vbRed
        Range(Cells(i, "H"), Cells(i, sonsut)).Interior.Color = xlNone
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
        
End Sub
 
sosorry

sosorry

Katılım
17 Ocak 2007
Mesajlar
193
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
04-06-2022
YUSUF44' Alıntı:
Aşağıdaki gibi dener misiniz?

PHP: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Or IsDate(Cells(i, "F")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        Cells(i, "F").Interior.Color = vbRed
        Range(Cells(i, "H"), Cells(i, sonsut)).Interior.Color = xlNone
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
       
End Sub
Genişletmek için tıkla ...
Screenshot_2.png

bu şekilde oluyor
 
YUSUF44

YUSUF44

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

PHP: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
If WorksheetFunction.CountA(Range("D8:D" & sonsat)) = 0 Then
    Cells.Interior.Color = xlNone
    Exit Sub
End If
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Or IsDate(Cells(i, "F")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        Cells(i, "F").Interior.Color = vbRed
        Range(Cells(i, "H"), Cells(i, sonsut)).Interior.Color = xlNone
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
        
End Sub
 
sosorry

sosorry

Katılım
17 Ocak 2007
Mesajlar
193
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
04-06-2022
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin:

PHP: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
If WorksheetFunction.CountA(Range("D8:D" & sonsat)) = 0 Then
    Cells.Interior.Color = xlNone
    Exit Sub
End If
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Or IsDate(Cells(i, "F")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        Cells(i, "F").Interior.Color = vbRed
        Range(Cells(i, "H"), Cells(i, sonsut)).Interior.Color = xlNone
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
       
End Sub
Genişletmek için tıkla ...
Evet oluyor ancak tüm tarihleri silince temizliyor yani dosyayı ekledim bakar mısınız? bir de dosya açılırken ve kaydederken aşırı yavaş. Ayrıca da 140MB :SScreenshot_3.png
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi kullanırsanız önce tüm renklendirmeleri iptal eder sonra, her satırı ayrı ayrı değerlendirir:

Kod: 
Sub gannt()
sonsat = WorksheetFunction.Max(8, Cells(Rows.Count, "D").End(3).Row)
sonsut = WorksheetFunction.Max(8, Cells(5, Columns.Count).End(xlToLeft).Column)
    Cells.Interior.Color = xlNone
Range("D5", Cells(sonsat, sonsut)).Interior.Color = xlNone
hata = 0
If IsDate([H5]) = False Then
    [H5].Interior.Color = vbRed
    hata = hata + 1
End If
For gun = 9 To sonsut
    If IsDate(Cells(5, gun)) = False Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
    If Cells(5, gun) <> Cells(5, gun - 1) + 1 Then
        Cells(5, gun).Interior.Color = vbRed
        hata = hata + 1
    End If
Next
If hata > 0 Then
    MsgBox "Tarih diziliminde " & hata & " adet hatalı hücre bulundu ve kırmızı ile işaretlendi!" _
        & Chr(10) & Chr(10) & "Lütfen önce tarih hücrelerini düzeltin!", vbCritical
    Exit Sub
End If
hata = 0
For i = 8 To sonsat
    If IsDate(Cells(i, "D")) = False Or IsDate(Cells(i, "F")) = False Then
        Cells(i, "D").Interior.Color = vbRed
        Cells(i, "F").Interior.Color = vbRed
        Range(Cells(i, "H"), Cells(i, sonsut)).Interior.Color = xlNone
        hata = hata + 1
    ElseIf Cells(i, "D") >= Cells(i, "F") Then
        Range("D" & i & ":F" & i).Interior.Color = vbRed
        hata = hata + 1
        GoTo 10
    End If
    gunyok = 0
    For gun = 8 To sonsut
        If Cells(5, gun) >= Cells(i, "D") And Cells(5, gun) < Cells(i, "F") Then
            gunyok = gunyok + 1
            If i Mod 2 = 0 Then
                Cells(i, gun).Interior.Color = 65535
            Else
                Cells(i, gun).Interior.Color = 49407
            End If
        End If
    Next
    If gunyok = 0 Then
        Range(Cells(i, "D"), Cells(i, sonsut)).Interior.Color = vbRed
    End If
10:
Next
If hata > 0 Or gunyok = 0 Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bazı hatalar bulundu ve hatalı hücreler kırmızıya boyandı!" _
        & Chr(10) & Chr(10) & "Hatalı hücreleri düzelttikten sonra makroyu tekrar çalıştırınız.", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Herhangi bir hata bulunamadı!", vbInformation
End If
        
End Sub
Dosya boyutuyla ilgili olarak benim diyebileceğim dosyanızdaki gereksiz biçimlendirmeleri iptal edin, boş hücrelerdeki biçimlendirmeleri kaldırın, şekil/resim vs varsa ve çok gerekli değilse silin. Dosyanız mümkün olduğu kadar sade ve basit olsun.
 
sosorry

sosorry

Katılım
17 Ocak 2007
Mesajlar
193
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
04-06-2022
tamamdır teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst