DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub test()
ASon = Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row
lst1 = Sheets("Sayfa1").Range("A2:A" & ASon)
CSon = Sheets("Sayfa1").Cells(Rows.Count, "C").End(xlUp).Row
lst2 = Sheets("Sayfa1").Range("C2:C" & ASon)
Dim w(1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(lst1)
key = Trim(lst1(i, 1))
If Not .Exists(key) Then
w(1) = 1
w(2) = 0
.Add key, w
Else
c = .Item(key)
c(1) = c(1) + 1
.Item(key) = c
End If
Next i
For i = 1 To UBound(lst2)
key = Trim(lst2(i, 1))
If Not .Exists(key) Then
w(1) = 0
w(2) = 1
.Add key, w
Else
c = .Item(key)
c(2) = c(2) + 1
.Item(key) = c
End If
Next i
keys = .keys
itms = .items
[e:G].Clear
For i = LBound(keys) To UBound(keys)
Cells(i + 2, 5) = keys(i)
Cells(i + 2, 6) = itms(i)(1)
Cells(i + 2, 7) = itms(i)(2)
If itms(i)(1) = itms(i)(2) Then Cells(i + 2, 5).Resize(1, 3).Interior.Color = vbYellow
Next i
End With
Erase lst1, lst2, itms, keys
End Sub
Merhaba, dosyayı ekliyorum.
=egersay(A:A;C3)
[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
Range("E:J").Clear
s = "Select [Sayfa1$].t1,1, (Select Count(*) From [Sayfa2$] Where [Sayfa1$].t1=[Sayfa2$].t1) From [Sayfa1$]"
rs.Open s, con, 1, 1
Range("E2").CopyFromRecordset rs: rs.Close
s = "Select [Sayfa2$].t1,1, (Select Count(*) From [Sayfa1$] Where [Sayfa2$].t1=[Sayfa1$].t1) From [Sayfa2$]"
rs.Open s, con, 1, 1
Range("H2").CopyFromRecordset rs
Columns.AutoFit
Set con = Nothing: Set rs = Nothing: s = ""
End Sub[/SIZE][/FONT]