sn feraz ve sn halil üstadım merhaba,
aslında ocak ayından aralık ayına kadar olacak. ben formülle olursa kalan kısmı kendim tamamlarım düşüncesiyle örnek bir sayfa eklemiştim. kod ile daha güzel olmuş.
ocak...aralık ayına kadar ayrı ayrı sayfalar oluşturdum. kodu bu haliyle uygulama imkanı varmı acaba,
ilginiz ve yardımlarınız için teşekkürler
saygılar
Rica ederiz, alttaki kodu deneyin.Aslında dizi formülleriylede olabilr tam bilmiyorum dizi formül olaylarını karışık yani.
Aslında koda tıklayınca isimleri otomatikte getirilebilir sıralı şekilde.
Private Sub btnAktar_Click()
Dim syf As Worksheet
Dim i As Byte, topla As Integer
Dim son As Byte, adres As String
Dim bul As Range
'Hafta ici bulmak icin
With ActiveSheet
Application.ScreenUpdating = False
.Range("B3:C" & Rows.Count).ClearContents
son = .Cells(Rows.Count, "A").End(3).Row
If son < 3 Then GoTo son
For i = 3 To son
For Each syf In Worksheets
If syf.Name <> .Name Then
If .Cells(i, "A").Value <> "" Then
Set bul = syf.Range("B:B").Find(.Cells(i, "A").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) < 6 Then topla = topla + 1
Set bul = syf.Range("B:B").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
End If
End If
Next
.Cells(i, "B").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
Next
'Hafta sonu bulmak icin
For i = 3 To son
For Each syf In Worksheets
If syf.Name <> .Name Then
If .Cells(i, "A").Value <> "" Then
Set bul = syf.Range("B:B").Find(.Cells(i, "A").Value, , , 1)
If Not bul Is Nothing Then
adres = bul.Address
Do
If Weekday(bul.Offset(0, -1), 2) >= 6 Then topla = topla + 1
Set bul = syf.Range("B:B").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
End If
End If
Next
.Cells(i, "C").Value = IIf(topla > 0, topla, "")
topla = Empty
Set bul = Nothing
Next
MsgBox "islem tamamlandi...", vbInformation, "Bilgi"
son:
Application.ScreenUpdating = True
End With
On Error Resume Next
Set bul = Nothing
Set syf = Nothing
End Sub
Bu dosyadada butona tıklamanız yeterli ay olan sayfalardaki isimleri benzersiz ve sıralı olarak sayfaya alıp sayıları getirir.
sn feraz,
eklediğiniz örnek tam da istediğim gibi,
yardımlarınız için teşekkür ederim,
elinize, emeğinize ve yüreğinize sağlık
saygılarımla
Hüsem Doğan
Rica ederiz,kolay gelsin.
bu da recordset yöntemiyle dilerim işinize yarar
1 - referanslardan microsoft ActiveX Data Objects xx Library eklenecek
2 - buton kodu:
Dim SQL, TbU As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
Application.ScreenUpdating = False
'Hafta ici bulmak icin
With ActiveSheet
.Range("A3:C" & Rows.Count).ClearContents
'hy burda sayfalardan birleştirme sorgusu oluşturulacak
For Each syf In Worksheets
If syf.Name <> .Name Then
TbU = TbU & "Union all " & "SELECT F1 as NobetTrh, F2 as Nobetci FROM [" & syf.Name & "$A3:B] "
End If
Next
End With
TbU = Mid(TbU, 11)
'hy birleşik sorgudan gerekli veri alınacak
SQL = "SELECT TbU.Nobetci, Sum(IIf(Weekday([NobetTrh],2)<6,1,0)) AS Hftici, Sum(IIf(Weekday([NobetTrh],2)>5,1,0)) AS HftSon " & _
"FROM(" & TbU & ") As TbU " & _
"GROUP BY TbU.Nobetci " & _
"HAVING (((TbU.Nobetci)<>''));"
Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
";extended properties=""excel 8.0;hdr=no"""
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1
'
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
Exit Sub
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst
Sheets("Toplam Liste").Range("A3").CopyFromRecordset ADO_RS
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
son:
Application.ScreenUpdating = True
End Sub
düzeltilmiş dosya