DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba
Beni bir kaç gündür uğraştıran derdime çare olmanız için mesajı yazdım. Belli bir görev listesi var, bu görev listesine göre tarih yazıldığında o tarihte görevli olan personeli sıralayıp gösterecek bir makro arıyorum.
Option Base 1
Sub gorevli_ogretmenler_59()
Dim myarr1(), myarr(2), a As Long, k As Byte, sat As Long
Dim sh As Worksheet, i As Long
Sheets("GÖREV").Select
Range("A5:E65536").Clear
If Not IsDate(Range("D3").Value) Then
MsgBox "D3 hücresine tarih girilmemeiş." & vbLf & _
"İşlem iptal edildi" & "evrengizlen@hotmail.com", vbCritical, "UYARI"
Range("D3").Select
Exit Sub
End If
Set sh = Sheets("PROGRAM")
sat = sh.Cells(65536, "B").End(xlUp).Row
If sat < 3 Then Exit Sub
myarr1 = sh.Range("B3:N" & sat)
ReDim myarr2(1 To 2, 1 To sat * 9)
For i = 1 To UBound(myarr1, 1)
If CDate(myarr1(i, 1)) = CDate(Range("D3").Value) Then
For k = 6 To 13
If myarr1(i, k) <> "" Then
a = a + 1
myarr2(1, a) = a
myarr2(2, a) = myarr1(i, k)
End If
Next k
End If
Next i
If a > 1 Then
ReDim Preserve myarr2(2, a)
Range("A5").Resize(a, 2) = Application.Transpose(myarr2)
MsgBox "İşlem Tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
Erase myarr1: Erase myarr2
End If
End Sub
Çok teşekkür ederim. Beni büyük bir yükten kurtardın. Büyüksün usta..