nöbet çizelgesi

[ocak26]

arkadaşlar merhaba
ekte nöbet çizelgesi var yardımlarınızı bekliyorum
çok teşekkür ederim

 

[Vedat Özer]

Merhabalar,

Aşağıdaki kodu deneyin.
Verilerin doğruluğunu kontrol edin.
Alternatif çözümler gelebilir şimidilik bununla idare edin. :redface:

Sub Test()
Dim sh As Worksheet, dd As Worksheet, sonsat As Long, i As Long, liste(), myarr(), n As Long
Sheets("Sayfa3").Select
Set dd = Sheets("Sayfa3")
Set sh = Sheets("Sayfa1")
Range("a4:c" & Rows.Count).ClearContents
sh.Range("b3:n3").AutoFilter
sonsat = sh.Cells(Rows.Count, "b").End(xlUp).Row
liste = sh.Range("A3:n" & sonsat).Value
ReDim myarr(1 To 3, 1 To sonsat - 1)
For i = 1 To UBound(liste)
    If liste(i, 9) = dd.Range("b3") Or liste(i, 10) = dd.Range("b3") Or liste(i, 11) = dd.Range("b3") Or _
    liste(i, 12) = dd.Range("b3") Or liste(i, 13) = dd.Range("b3") Or liste(i, 14) = dd.Range("b3") Then
        n = n + 1
        myarr(1, n) = liste(i, 2)
        myarr(2, n) = liste(i, 3)
        myarr(3, n) = liste(i, 4)
    End If
Next i
Erase liste
Application.ScreenUpdating = False
If n > 0 Then
    ReDim Preserve myarr(1 To 3, 1 To n)
    Range("A4").Resize(n, 3) = Application.Transpose(myarr)
End If
Erase myarr: Set sh = Nothing
Set dd = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı.", vbCritical
End Sub