• DİKKAT

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

Vardiya Belirleme Hk.

V

valentino06

Katılım
19 Şubat 2007
Mesajlar
630
Excel Vers. ve Dili
Ofis 365 Tr- 64 Bit
Merhaba,
Hocalarım yardımınıza ihtiyacım var. Çalışmış olduğum Firmada 3. vardiya uygulaması vardır. benim yapmak istediğim Veriler sayfasında A sütununda belirlemiş olduğum vardiya kodlarından herhangi birini yazdığımda vardiya listesine vardiya kodlarına göre aktarmak istiyorum. ve vardiyaya göre farklı bir renk olmasını , herhangi bir vardiya bitiminde tarih aralığı kısmını otomatik getirmek istiyorum tabi olabilirse çok teşekkür ederim. Allah kat kat razı olsun.
 

Ekli dosyalar

İstediğiniz aynı satıra şeklinde ise aşağıdaki gibi. (Veriler sayfasında 3 satır diğer sayfada 3. satıra gidiyor.) Eğer her değişiklik yeni kayıt derseniz. O zaman değiştireyim kodları.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1, s2 As Worksheet
Set s2 = Sheets("Vardiya")
Set s1 = Sheets("Veriler")
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
With Target
  If .Value = "1" Then
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "G").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "2" Then
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "H").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "3" Then
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "I").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  End If
End With
End Sub
 
Veriler sayfasının sayfa kod kısmına yazılacak kodlar.
 
Merhaba,
Askm hocam hata veriyor." compile error Syntax error " lütfen yardımcı olabilirmisiniz.
 
Örnek dosya ektedir. Veriler sayfası A sütununda herhangi bir veriyi değiştirin. Direkt diğer sayfaya veriler gidecek. Normalde renk kodları da ekledim ama sayfadan mı tam incelemedim renk kodu çalışmadı.
 

Ekli dosyalar

Askm hocam teşekkür ederim. veriler sayfasında değişiklik yaptığım zaman bir önceki vardiyayı silmiyorum. örnek a kişi 1. vardiya yazımışım daha sonra 2 yaptığım zaman her ikisinide gösteriyor. vardiya sayfasına attığı zaman renkleri değiştirmiyor. silince farklı renkler çıkıyor.
 
Renk kodlarını 1 için Kırmızı, 2 için sarı, 3 için mavi yapmıştım ama işlem yapmıyor.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1, s2 As Worksheet
Set s2 = Sheets("Vardiya")
Set s1 = Sheets("Veriler")
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
With Target
  
  If .Value = "1" Then
      s2.Cells(Target.Row, "H").Value = ""
      s2.Cells(Target.Row, "I").Value = ""
      s2.Cells(Target.Row, "H").Interior.Color = xlNone
      s2.Cells(Target.Row, "I").Interior.Color = xlNone
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "G").Value = s1.Cells(Target.Row, "A").Value
      s2.Cells(Target.Row, "G").Interior.Color = vbRed
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "2" Then
      s2.Cells(Target.Row, "G").Value = ""
      s2.Cells(Target.Row, "I").Value = ""
      s2.Cells(Target.Row, "G").Interior.Color = xlNone
      s2.Cells(Target.Row, "I").Interior.Color = xlNone
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "H").Value = s1.Cells(Target.Row, "A").Value
      s2.Cells(Target.Row, "H").Interior.Color = vbYellow
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "3" Then
      s2.Cells(Target.Row, "G").Value = ""
      s2.Cells(Target.Row, "H").Value = ""
      s2.Cells(Target.Row, "G").Interior.Color = xlNone
      s2.Cells(Target.Row, "H").Interior.Color = xlNone
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "I").Value = s1.Cells(Target.Row, "A").Value
      s2.Cells(Target.Row, "I").Interior.Color = vbBlue
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  End If
End With
End Sub
 
İsterseniz bilgileri boş yeni sayfalara aktarıp deneyin. Normalde renk vermesi gerek ama olmuyor. Çizgi sitilinde vs. olabilir belki.
 
merhaba,
Askm hocam hata veriyor. son eklemiş olduğunuz kod renk olayını kaldırabilirmiyiz. çok ta önemli değil.
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1, s2 As Worksheet
Set s2 = Sheets("Vardiya")
Set s1 = Sheets("Veriler")
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
With Target
  
  If .Value = "1" Then
      s2.Cells(Target.Row, "H").Value = ""
      s2.Cells(Target.Row, "I").Value = ""
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "G").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "2" Then
      s2.Cells(Target.Row, "G").Value = ""
      s2.Cells(Target.Row, "I").Value = ""
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "H").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  ElseIf .Value = "3" Then
      s2.Cells(Target.Row, "G").Value = ""
      s2.Cells(Target.Row, "H").Value = ""
      s2.Cells(Target.Row, "C").Value = s1.Cells(Target.Row, "C").Value
      s2.Cells(Target.Row, "D").Value = s1.Cells(Target.Row, "D").Value
      s2.Cells(Target.Row, "E").Value = s1.Cells(Target.Row, "E").Value
      s2.Cells(Target.Row, "F").Value = s1.Cells(Target.Row, "F").Value
      s2.Cells(Target.Row, "I").Value = s1.Cells(Target.Row, "A").Value
      
      s2.Cells(Target.Row, "J").Value = s1.Cells(Target.Row, "J").Value
  End If
End With
End Sub
 
Askm hocam çok fazla oluyorum özür dilerim.Vardiya sayfasına sıralattırma olasılığımız var mı 1. ler hepsi alt alta 2.ler hepsi alt alta 3. ler hepsi alt alta yapılabilir mi bilmiyorum. eğer yapılabilirse harika olur. çok teşekkür ederim.
 
Hücreye girince değer atması yerine butona tıklayarak giriş yapmayı isterseniz daha iyi olur o zaman. Şu andaki kodlar satır numarasına göre çalışıyor. Örneğin 10. sıradaki veri sıralama sonrası 14. e gelirse. Veri değiştirdiğiniz zaman 10 sıradaki veri değişmiş olacak. Yani diğer bilgiler karışacak.
Bunun yerine Veriler sayfasına verileri girin. Butona basınca diğer sayfaya sıralı olarak geçsin. Önce 1 ler, sonra 2 ler, daha sonra da 3 ler.
 
Askm hocam teşekkür ederim. veriler sayfasında A sütünu boşaltığımda vardiya listesinde veriler kalıyor. veriler listesinde a sütunu boş olunca vardiya sayfası da boşaltabilirmiyiz. çok teşekkür ederim.
 
Buton ile yapılırsa hem sıralama hem veri temizleme işlemi daha seri olarak yapılacaktır. Eğer bu şekilde buton ile isterseniz, akşam müsait olunca yazıp yeniden yükleme yaparım. Ama hücreye bağlı kod olursa ne sıralama olur ne de veri temizleme sağlıklı oluyor.
 
Merhaba,
Askm hocam buton olur. size zahmet olmazsa çok iyi olur.
Hayırlı Akşamlar...
 
Aşağıdaki kodlar ile veriler aktarılıyor ve renk veriyor.
Kod: 
Sub Askm_Aktar()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Veriler")
Set s2 = Sheets("Vardiya")
Dim Son As Long
Son = s1.Range("A" & Rows.Count).End(xlUp).Row
s2.Range("C3:J65000").ClearContents
s2.Range("C3:J65000").Interior.Color = xlNone
a = 2
For x = 1 To 3
    For i = 4 To Son
        If s1.Cells(i, 1) = x Then
            a = a + 1
            s2.Cells(a, "C").Value = s1.Cells(i, "C").Value
            s2.Cells(a, "D").Value = s1.Cells(i, "D").Value
            s2.Cells(a, "E").Value = s1.Cells(i, "E").Value
            s2.Cells(a, "F").Value = s1.Cells(i, "F").Value
            s2.Cells(a, x + 6).Value = s1.Cells(i, "A").Value
            If s1.Cells(i, 1) = 1 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = vbRed
            ElseIf s1.Cells(i, 1) = 2 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = vbYellow
            ElseIf s1.Cells(i, 1) = 3 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = vbCyan
            End If
        End If
    Next i
Next x
MsgBox "Aktarma işlemi tamamlanmıştır...", vbInformation, "ASKM"
End Sub
 
Merhaba,
Günaydın Askm hocam çok teşekkür ederim. güzel olmuş yalnız renk olayı gelmiyor. eğer olmuyorsa renk olayından vaz geçelim. Allah kat kat razı olsun. Hakkınızı helal edin.
 
Renk olayı gelmemesi koşullu biçimlendirme eklemiş olduğunuzdanmış. Sayfadaki bütün koşullu biçimlendirmeyi temizleyin. Renk gelecektir.(Bende geldi)
 
teşekkür ederim. Askm hocam tarih aralığını makro ile otomatik getirme olasılığımız var mı
 
Nasıl istiyorsunuz. Alamadım tam olarak.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst