• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Gantt Diyagramı yardım

  • Konbuyu başlatan Konbuyu başlatan sosorry
  • Başlangıç tarihi Başlangıç tarihi
Dosyanızı buna örnek olacak şekilde paylaşır mısınız? Yani hangi durumda silme hangi durumda boyama yapılacak?
 
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.
 
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
 
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
 
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
 
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
 
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.
 
tamamdır teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst