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