• DİKKAT

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

Personelin çalıştığı günleri renklendirmek (Koşullu biçimlendirme)

  • Konbuyu başlatan Konbuyu başlatan S.Yiğit
  • Başlangıç tarihi Başlangıç tarihi
S.Yiğit

S.Yiğit

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2008
Mesajlar
1,748
Excel Vers. ve Dili
2019 TR
Merhabalar,

Kısaca anlatmak personeller var ve bir tarih sayfamız var.. amacımız tarih sayfasında personelin çalıştığı günleri reklendirmek.

Örnek Plan sayfasında Ayhan için planlanan sevkiyat tarihini yazacağız ve kaç gün orda kalacağını yazacağız. tarih sayfamızda renlendirme yapacak.

Ayhan için renklendirmeyi ben yaptım, örnek olması için..

Eki incelerseniz demek istediğimi daha basit anlarsınız.

Bulduğum örnekler farklı. ben tarih artı gün sayısı girdiğim için sıkıntı oldu..
 

Ekli dosyalar

S.Yiğit' Alıntı:
Merhabalar,

Kısaca anlatmak personeller var ve bir tarih sayfamız var.. amacımız tarih sayfasında personelin çalıştığı günleri reklendirmek.

Örnek Plan sayfasında Ayhan için planlanan sevkiyat tarihini yazacağız ve kaç gün orda kalacağını yazacağız. tarih sayfamızda renlendirme yapacak.

Ayhan için renklendirmeyi ben yaptım, örnek olması için..

Eki incelerseniz demek istediğimi daha basit anlarsınız.

Bulduğum örnekler farklı. ben tarih artı gün sayısı girdiğim için sıkıntı oldu..
Genişletmek için tıkla ...

dasyanda plan sayfasında d sutünunda isimler var soyo isim yok
tarih sayfasında a sutünunda ad soyad var bunların birbirine uyumlu olması lazım.

Kod: 
Sub aktar()
Cells.Select
Selection.Interior.ColorIndex = xlNone
Range("a1").Select
For r = 2 To Worksheets("PLAN").Cells(Rows.Count, "c").End(3).Row
aranan1 = Sheets("PLAN").Cells(r, 3).Value
aranan2 = Sheets("PLAN").Cells(r, 4).Value
aranan3 = Sheets("PLAN").Cells(r, 5).Value - 1
If Sheets("PLAN").Cells(r, 3).Value <> "" Then
For i = 6 To Worksheets("TARİH").Cells(Rows.Count, "A").End(3).Row
bulunan1 = Sheets("TARİH").Cells(i, 1).Value
If aranan1 = bulunan1 Then
For n = 2 To 256
bulunan2 = Sheets("TARİH").Cells(4, n).Value
If aranan2 = bulunan2 Then
For j = n To aranan3 + n
Sheets("TARİH").Cells(i, j).Interior.ColorIndex = 3
Next j
End If
Next n
End If
Next i
End If
Next r
MsgBox "işlem tamam"
End Sub
 
kadda küçük bir düzeltme yaptım ekli dosyanızı kontrol ediniz.
 

Ekli dosyalar

Hocam soy isimleri düzeltmeyi unutmuşum. Kodda ufak bir düzeltme yapmamız lazım..

Birincisi örnek Ayhan 05.02.2011 tarihinde 3 günlük göreve gidiyor. tarih sayfasında 6 ve 7 şubat boyanmış yani bir gün geç boyuyor. bitiş kısmı doğru.


Birde mümkünse eğer o görevin proje no'larını boyadığı kutucukların içine yazdırabilir miyiz? şart değil ama olursada çok güzel olur. (PLAN sayfasında a sutunundaki proje no'ları.)

Ekte kodun uygulanmış hali mevcuttur. isim soy isimleride düzelttim.

Yardımlarınız için çok teşekkür ederim..
 

Ekli dosyalar

Hocam bu sefer olmuş fakat sutunlar ağustos 2011 de bitiyor buna ilave yapmam lazım

birde proje nolarıda geldimi süper olur.. Çok teşekkürler..
 
kodu söylediğiniz doğrultuda kırmızı bölümü ekledim.

Sub aktar()
Cells.Select
Selection.Interior.ColorIndex = xlNone
Range("a1").Select
For r = 2 To Worksheets("PLAN").Cells(Rows.Count, "c").End(3).Row
aranan1 = Sheets("PLAN").Cells(r, 3).Value
aranan2 = Sheets("PLAN").Cells(r, 4).Value
aranan3 = Sheets("PLAN").Cells(r, 5).Value - 1
If Sheets("PLAN").Cells(r, 3).Value <> "" Then
For i = 6 To Worksheets("TARİH").Cells(Rows.Count, "A").End(3).Row
bulunan1 = Sheets("TARİH").Cells(i, 1).Value
If aranan1 = bulunan1 Then
For n = 2 To 256
bulunan2 = Sheets("TARİH").Cells(4, n).Value
If aranan2 = bulunan2 Then
For j = n To aranan3 + n
Sheets("TARİH").Cells(i, j).Interior.ColorIndex = 3
Sheets("TARİH").Cells(i, j).Value = Sheets("PLAN").Cells(r, 1).Value
Next j
End If
Next n
End If
Next i
End If
Next r
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...
 
Hocam çok teşekkür ederim, emeğinize sağlık.. Mesai bitti. Eve gittiğimde inceleyeceğim.
 
Herkese günaydın,

Yukarıda Halit hocamın verdiği kodu kendi dosyama uygulayamadım..

Benim dosyamda personel isimleri G sutununda Halit hocamın verdiği kodda C sutununda
Benim dosyamda tarih K sutununda Halit hocamın verdiği kodda D sutununda
Benim dosyamda işin yapılacağı gün sayısı L sutununda Halit hocamın verdiği kodda E sutununda

Sayfa isimleri herşeyi aynı ama kod hata verdi.

Not: benim çalışmamda başlıklar 2 satır yani birinci satır boş ikinci satırda başlıklar var.(Proje no, Tedarikçi, Montaj tipi vs..)

hata veren yer: For r = 2 To Worksheets("ANATABLO").Cells(Rows.Count, "G").End(3).Row
 
S.Yiğit' Alıntı:
Herkese günaydın,

Yukarıda Halit hocamın verdiği kodu kendi dosyama uygulayamadım..

Benim dosyamda personel isimleri G sutununda Halit hocamın verdiği kodda C sutununda
Benim dosyamda tarih K sutununda Halit hocamın verdiği kodda D sutununda
Benim dosyamda işin yapılacağı gün sayısı L sutununda Halit hocamın verdiği kodda E sutununda

Sayfa isimleri herşeyi aynı ama kod hata verdi.

Not: benim çalışmamda başlıklar 2 satır yani birinci satır boş ikinci satırda başlıklar var.(Proje no, Tedarikçi, Montaj tipi vs..)

hata veren yer: For r = 2 To Worksheets("ANATABLO").Cells(Rows.Count, "G").End(3).Row
Genişletmek için tıkla ...

o satatırlarda ya tarih yok yada gün sayısı yok ondan kod hataveriyor.

Kod: 
Sub aktar()
Worksheets("TARİH").Rows("6:1000").ClearContents
Worksheets("TARİH").Rows("6:1000").Interior.ColorIndex = xlNone
sut = Worksheets("TARİH").Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
sat = 6
For r = 2 To Worksheets("PLAN").Cells(Rows.Count, "g").End(3).Row
aranan1 = Sheets("PLAN").Cells(r, "g").Value
deg = 0
If Sheets("PLAN").Cells(r, "g").Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("PLAN").Range("g2:g" & r), aranan1) = 1 Then
For i = r To Worksheets("PLAN").Cells(Rows.Count, "g").End(3).Row
If Sheets("PLAN").Cells(i, "g").Value <> "?" Then
If IsDate(Sheets("PLAN").Cells(i, "k").Value) = True Then
If IsNumeric(Sheets("PLAN").Cells(i, "L").Value) = True Then
aranan2 = Sheets("PLAN").Cells(i, "k").Value
aranan3 = Sheets("PLAN").Cells(i, "l").Value - 1
If aranan1 = Sheets("PLAN").Cells(i, "g").Value Then
For n = 2 To sut
If aranan2 = Sheets("TARİH").Cells(4, n).Value Then
deg = 1
Sheets("TARİH").Cells(sat, 1).Value = Sheets("PLAN").Cells(i, "g").Value
For j = n To aranan3 + n
Sheets("TARİH").Cells(sat, j).Interior.ColorIndex = 3
Sheets("TARİH").Cells(sat, j).Value = Sheets("PLAN").Cells(i, 1).Value
Next j
Exit For
End If
Next n
End If
End If
End If
End If
Next i
End If
End If
If deg = 1 Then
sat = sat + 1
End If
Next r
MsgBox "işlem tamam"
End Sub
 
Hocam merhaba,

Haklısın bazı işlerin planları belli olmadığı için boş bırakıyoruz. Şuan kod tam istediğim gibi oldu, çok teşekkür ederim.. Küçük bir ekleme yapabilir miyiz?

Boyama yaptığı yerde manuel boyanan hücreler var bunlara dokunmadan boyama işlemini yapsa olur mu. Manuel boyadığımız yerlerin tarihlerle alakası yok. yani kodun boyadığı yerle işimiz yok olursada kod işini yapıp boyasın.. Sonuçta başka bir kod ile aynı personele aynı tarihlerde iki iş verilmesini engelledik. Yardımlarınız için çok teşekkürler..
 
S.Yiğit' Alıntı:
Hocam merhaba,

Haklısın bazı işlerin planları belli olmadığı için boş bırakıyoruz. Şuan kod tam istediğim gibi oldu, çok teşekkür ederim.. Küçük bir ekleme yapabilir miyiz?

Boyama yaptığı yerde manuel boyanan hücreler var bunlara dokunmadan boyama işlemini yapsa olur mu. Manuel boyadığımız yerlerin tarihlerle alakası yok. yani kodun boyadığı yerle işimiz yok olursada kod işini yapıp boyasın.. Sonuçta başka bir kod ile aynı personele aynı tarihlerde iki iş verilmesini engelledik. Yardımlarınız için çok teşekkürler..
Genişletmek için tıkla ...

biçimlendir ile renklendirilmiştir hücreler dolayısıyla siz elle renklendirdiğiniz hücrelere dokunmuyacaktır.

Kod: 
Sub aktar()
Worksheets("TARİH").Rows("6:1000").FormatConditions.Delete
Worksheets("TARİH").Rows("6:1000").ClearContents
sut = Worksheets("TARİH").Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
sat = 6
For r = 2 To Worksheets("PLAN").Cells(Rows.Count, "g").End(3).Row
aranan1 = Sheets("PLAN").Cells(r, "g").Value
deg = 0
If Sheets("PLAN").Cells(r, "g").Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("PLAN").Range("g2:g" & r), aranan1) = 1 Then
For i = r To Worksheets("PLAN").Cells(Rows.Count, "g").End(3).Row
If Sheets("PLAN").Cells(i, "g").Value <> "?" Then
If IsDate(Sheets("PLAN").Cells(i, "k").Value) = True Then
If IsNumeric(Sheets("PLAN").Cells(i, "L").Value) = True Then
aranan2 = Sheets("PLAN").Cells(i, "k").Value
aranan3 = Sheets("PLAN").Cells(i, "l").Value - 1
If aranan1 = Sheets("PLAN").Cells(i, "g").Value Then
For n = 2 To sut
If aranan2 = Sheets("TARİH").Cells(4, n).Value Then
deg = 1
Sheets("TARİH").Cells(sat, 1).Value = Sheets("PLAN").Cells(i, "g").Value
For j = n To aranan3 + n
Sheets("TARİH").Cells(sat, j).FormatConditions.Delete
Sheets("TARİH").Cells(sat, j).FormatConditions.Add Type:=xlExpression, Formula1:="=r" & sat & "c" & j & ">0"
Sheets("TARİH").Cells(sat, j).FormatConditions(1).Interior.ColorIndex = 3
Sheets("TARİH").Cells(sat, j).Value = Sheets("PLAN").Cells(i, 1).Value
Next j
Exit For
End If
Next n
End If
End If
End If
End If
Next i
End If
End If
If deg = 1 Then
sat = sat + 1
End If
Next r
MsgBox "işlem tamam"
End Sub
 
Hocam elinize sağlık.. Çok teşekkür ederim..
 
Halit hocam merhaba,

Benim bir koda daha ihtiyacım var.. bu seferki kodda aynı gibi ama bu sefer tedarikçilere verilen iş planına göre tedarikçi sayfasında boyama yapmak.. Sıkıntımız aynı tedarikçiye aynı tarihlerde bir kaç iş verebiliyoruz.. bunun için boyama yapılaan sayfada birinci göre ikinci görev vb.. diye sutun açtım.. ama formatta sayfada değişiklik yapabiliriz. herhangi bir kısıtlamamız yok, tek istediğimiz tedarikçilerin çalıştığı günleri boyamak.. eki incelerseniz anlayabilirsiniz.. Örnek olması için çelik firmasının reklendirmesini ben manuel olarak yapmaya çalıştım ama ilk kod izin vermedi :) tedarikçiye aynı tarihlerde iş veremiyoruz.. İlk kodda da değişiklik yapmamız gerekecek..

Sıralamamız Montaj tipi ne? Süpervisor ise aynı tarihlerde iş vermeyecek
Montaj tipi tedarikçi ise aynı günlerde iş verebilecek ve buna göre boyama yapacak.. her ikisinde de boyadığı hücrelere proje noları gelecek.. PLAN sayfası hariç diğer sayfalarda değişiklik yapabiliriz...
 

Ekli dosyalar

Merhabalar,

İki konum benden kaynaklanan sebeplerden birbirine karıştı. Yeni bir dosya hazırlayıp yeni bir konu açarak tek konu üzerinden gitmeye çalışacağım.. Yardımcı olan herkese teşekkürler..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst