Kapalı dosyada bulunan bir sütun ile karşılaştırma

Katılım
24 Şubat 2009
Mesajlar
1,070
Excel Vers. ve Dili
2016
Merhaba arkadaşlar; Hayırlı Günler diliyorum.
Kapalı olan ve doysa yolu "D: \ Belgelerim \ Personel \ PERSONEL LİSTESİ.xlsm" olan bir dosyamın B sütununda bulunan sicilleri açık olan dosyamın E sütunundaki sicillerle karşılaştırarak, olmayanları örnek dosyamdaki gibi hazırlamak için nasıl bir kod yazılır. Teşekkürler.
 

Ekli dosyalar

Son düzenleme:
Katılım
24 Şubat 2009
Mesajlar
1,070
Excel Vers. ve Dili
2016
siciller ile karşılaştırarak olmayanları örnekteki gibi yazmasını istiyorum. Saygılarımla....
 

Erdem Akdemir

Destek Ekibi
Destek Ekibi
Katılım
4 Mayıs 2007
Mesajlar
3,596
Excel Vers. ve Dili
2016 PRO TÜRKÇE-İNG. 64 BİT
Merhaba,

Aşağıdaki kodu kullanabilirsiniz.

Sub dememe()

Range("AV7:AX20000").ClearContents

yol = "D:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm"

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select Sicili from[LİSTE$] where sicili is not null "
Set rs = con.Execute(sorgu)

x = 7

For Each deg In rs.getrows

s = Application.CountIf(Range("E7:E20000"), deg)

If s = 0 Then

sorgu = "select Adı+' '+Soyadı,MESAİ from [liste$] where Sicili = " & deg & " "
Set rs = con.Execute(sorgu)

Cells(x, "av") = deg
Cells(x, "aw") = rs.Fields.Item(0)
Cells(x, "ax") = rs.Fields.Item(1)
x = x + 1
End If

Next deg

End Sub
 
Son düzenleme:
Katılım
24 Şubat 2009
Mesajlar
1,070
Excel Vers. ve Dili
2016
Merhabalar; Erdem Beyin hazırlamış olduğu 3 nolu cevaptaki kod güzel olarak çalıştı, burada bir isteğim daha olacak, aşağıda yeni dosyayı ekledim, açık olan Bordro dosyasındaki personeli kapalı olan Personel Listesi Dosyası ile karşılaştırsın, Personel dosyasında olmayanları bunun altına eklesin, ayrıntısı aşağıda eklemiş olduğum dosyada anlattım. Teşekkürler.
 
Katılım
24 Şubat 2009
Mesajlar
1,070
Excel Vers. ve Dili
2016
Merhabalar; Erdem Beyin hazırlamış olduğu 3 nolu cevaptaki kod güzel olarak çalıştı, burada bir isteğim daha olacak, aşağıda yeni dosyayı ekledim, açık olan Bordro dosyasındaki personeli kapalı olan Personel Listesi Dosyası ile karşılaştırsın, Personel dosyasında olmayanları bunun altına eklesin, ayrıntısı aşağıda eklemiş olduğum dosyada anlattım. Teşekkürler.
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Dosyanızda bulunan aşağıdaki kodlarınıza işaretli satırlar eklendi
Kod:
Sub Olmayanlar()

  Set dic = CreateObject("scripting.dictionary") ' <-----------------------1
Range("AV7:AX20000").ClearContents
Range("AV7:AX20000").Font.ColorIndex = xlAutomatic '<--------------------2
yol = "D:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm"

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select Sicili from[LİSTE$] where sicili is not null "
Set rs = con.Execute(sorgu)

x = 7

For Each deg In rs.getrows

s = Application.CountIf(Range("E7:E20000"), deg)

If s = 0 Then

sorgu = "select Adı+' '+Soyadı,MESAİ from [liste$] where Sicili = " & deg & " "
Set rs = con.Execute(sorgu)

Cells(x, "av") = deg
Cells(x, "aw") = rs.Fields.Item(0)
Cells(x, "ax") = rs.Fields.Item(1)
x = x + 1
Else
If Not dic.exists(deg) Then dic.Add deg, "" '<----------------------------3

End If

Next deg

'---------------------------------------------------------------------4
For Each j In Range("E7:E" & Cells(Rows.Count, "E").End(3).Row)
If Not dic.exists(j.Value) Then
Cells(x, "av") = j.Value
Cells(x, "aw") = Cells(j.Row, "B") & " " & Cells(j.Row, "C")
Range("AV" & x & ":AW" & x).Font.Color = vbRed
x = x + 1
End If
Next
'----------------------
End Sub
 
Üst