Listeleme hk.

[Ziynettin]

Kod revize edildi tekrar deneyin.

 

[nongeyikm]

Ziynettin Bey merhaba,

Çok güzel oldu. Elinize beyninize sağlık. Allah razı olsun.

Saygılar sunarım, kalın sağlıcakla.

 

[nongeyikm]

Ziynettin Bey,

Aceleci davrandım. makronuzda I3:K alanını temizleme işlemi eksik kalmış. Makronuza ekleyebilirmisiniz.

 

[Ziynettin]

[i3].Resize(sat, 3) = b satırından önce Range("I3:K" & Rows.Count).ClearContents kod satırını yazınız.


Range("I3:K" & Rows.Count).ClearContents
[i3].Resize(sat, 3) = b
MsgBox "işlem tamam.", vbInformation

 

[nongeyikm]

ziynettin bey gününüz aydın olsun.

Çok teşekkür ederim. Her şeyiyle harika oldu.

Hayırlı günler dilerim

 

[nongeyikm]

Sn. Ziynettin Bey,

Makroda bir hata ile karşılaştım. Şayet kişinin toplamda sadece 1 gün kullandığı izin var ise, hiç bir işlem yapmıyor. 2 gün olunca sorun olmuyor. Zamanınız var ise bakabilirmisiniz.

Saygılar sunarım.


Sub kod_1()
a = Range("F3:F" & Cells(Rows.Count, "F").End(3).Row).Value
On Error Resume Next

trh_1 = a(1, 1)
trh_2 = a(UBound(a), 1)
son = trh_2 - trh_1
ReDim b(1 To son + 1, 1 To 1)
For i = 1 To son + 1
trh_3 = DateAdd("d", i - 1, a(1, 1))
If trh_3 Mod 7 <> 1 Then
say = say + 1
For j = 1 To UBound(a)
If trh_3 = a(j, 1) Then
b(say, 1) = trh_3
End If
Next j
End If

Next i

n = 1
Set d = CreateObject("scripting.dictionary")
ReDim c(1 To say, 1 To 2)
For i = 1 To say
If b(i, 1) <> "" Then
c(i, 1) = n
Else
n = n + 1
End If
c(i, 2) = b(i, 1)
Next i

ReDim b(1 To UBound(c), 1 To 3)
For i = 1 To say
If c(i, 1) <> "" Then
If Not d.exists(c(i, 1)) Then
d(c(i, 1)) = d.Count + 1
sat = d.Count
b(sat, 1) = c(i, 2)
End If
sat1 = d(c(i, 1))
b(sat1, 2) = DateAdd("d", 1, c(i, 2))
b(sat1, 3) = b(sat1, 3) + 1
End If
Next i
Range("I3:K" & Rows.Count).ClearContents
[i3].Resize(sat, 3) = b
MsgBox "işlem tamam.", vbInformation
End Sub