• DİKKAT

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

Vardiya Belirleme Hk.

Hocam Vardiya tarih Aralığı varya 14 günde 1 değişiyor. hücreye çift tıklandığında bu iki aralığı hücreye otomatik getirme şanşmız varmı hocam vardiya listesindeki renkleri daha açık yapabilirmiyiz. lütfen
 
Bu şekilde olması için öncelikle tarih aralığını bir yere yazmanız gerek. Örneğin T1 e sonrasında çift tıklama özelliği ile o veriyi çift tıkladığınız satıra getirebilir. Renk kodlarını siz hangi renk istiyorsanız örnek bir excelde ekleyin. O renkleri yapabilirim.
 
Dediğim şekilde T1 hücresine tarih girdiğinizde çalışacak şekilde kod aşağıdadır.
Sayfanın kod kısmına ekleyin. (Çift tıkladığınız hücreye T1 deki veriyi çeker.)
Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C4:C65000]) Is Nothing Then Exit Sub
Target.Value = Range("T1") 
End Sub
 
Askm hocam renkleri ekledim açıklama kısmına rakamlar geliyor. sağolun. Çok teşekkür ederim.
 

Ekli dosyalar

Kodları değiştirin.
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 = RGB(252, 228, 214)
            ElseIf s1.Cells(i, 1) = 2 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(217, 225, 242)
            ElseIf s1.Cells(i, 1) = 3 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(226, 239, 218)
            End If
        End If
    Next i
Next x
s2.Select 'Sayfa2 yi aktif etmek için. Hata verirse select kelimesini active yapın.
MsgBox "Aktarma işlemi tamamlanmıştır...", vbInformation, "ASKM"
End Sub
 
Askm hocam tekrar rahatsız ediyorum. veriler sayfasında "A" sütununda yapmış olduğumuz vardiya durumuna göre vardiya saatlerini makro ile otomatik getirebilirmiyiz. Eğer yapabilirsek çok güzel olur.
 
B sütununda sıra numarası var. Bunlar hariç hepsi geliyor.
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("A3:A65000").ClearContents
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, "A").Value = s1.Cells(i, "A").Value
            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 = RGB(252, 228, 214)
            ElseIf s1.Cells(i, 1) = 2 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(217, 225, 242)
            ElseIf s1.Cells(i, 1) = 3 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(226, 239, 218)
            End If
        End If
    Next i
Next x
s2.Select
MsgBox "Aktarma işlemi tamamlanmıştır...", vbInformation, "ASKM"
End Sub
 
Askm hocam teşekkür ederim. 1 ve 3. vardiyalarda aynı saat geliyor. 1. vardiya 00:00 - 08:00 2.vardiya 08:00 - 16:00 3.vardiya 16:00 - 24:00 gelmesi lazım acaba ben mi yanlış bir şey yapıyorum.
 
Vardiya ile ilgili bir kod yazmamıştım ki. Veriler sayfasında ne varsa onu alıyor. Sanırım aşağıdaki gibi mi olacak.
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("A3:A65000").ClearContents
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, "A").Value = s1.Cells(i, "A").Value
            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 = Format(s1.Cells(x + 3, "O").Value, "hh:mm")
            s2.Cells(a, "F").Value = Format(s1.Cells(x + 3, "P").Value, "hh:mm")
            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 = RGB(252, 228, 214)
            ElseIf s1.Cells(i, 1) = 2 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(217, 225, 242)
            ElseIf s1.Cells(i, 1) = 3 Then
                s2.Range("C" & a & ":J" & a).Interior.Color = RGB(226, 239, 218)
            End If
        End If
    Next i
Next x
s2.Select
MsgBox "Aktarma işlemi tamamlanmıştır...", vbInformation, "ASKM"
End Sub
 
Askm hocam ben anlatamadım. hepsi geliyor. veriler sayfasındaki başlama ve bitiş saatlerini manuel giriyorum. aktarma işlemi yaparken dolayısıyla veriyi burdan çekip aktarıyor. A sütünunda ne yazarsam saatlerde ona göre A sütununa yazan vardiyaya göre değişsin istiyorum.
Veriler sayfasında A sütunu kriter olsun istiyorum. Örnek 2 yazarsam 2. karşılığı saatleri aktarsın. 3. yazarsam. 3.karşılığı olan saatleri aktarsın. 1 yazarsam 1 karşılığı olan saatleri aktarsın. kusura bakmayın sizi uğraştırıyorum.
 
Şu andaki kodda vardiyayı O ve P sütununa eklediğiniz vardiya saatlerine göre alıyor.
 
Hocam bu son koda ilave yapıp vardiya içine görev tanımına göre de ayırma ve 1 2 3 ün arasına boşluk koydurabilir miyiz belirgin olması adına
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst