sayfalar arası karşılaştırma ve veri yazma

[andon]

merhaba
elimdeki tabloya göre; sayfa1 ve sayfa2 de ki tablollardaki v14 deki yeşile boyanmış alandaki numaralara bakarak ve karşılaştırarak, sayfa2 deki sadece kırmızı ile boyanmış alandaki v11 sütununda yazılan verileri sayfa1 de sarı ile boyanmış alandaki v11 sütununa yazdırmak istiyorum.
değerli hocalarımız yardımlarını esirgemezler ise çok minnettar kalırım.
saygılarımla.

 

[Civan Jack]

Şu kodları bir deneyiniz;

Sub Emre()
    Dim con As Object, rs As Object
    Set con = CreateObject("adodb.connection")
    con.Open "provideR=microsoft.jet.oledb.4.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes"""
    Set rs = CreateObject("adodb.recordset")
    rs.Open "select v11 from [Sayfa2$] where exists (select v11 from [Sayfa1$] where [Sayfa2$].[v14]=[Sayfa1$].[v14])", con, 1, 1
        If rs.RecordCount > 0 Then
            Range("K2").CopyFromRecordset rs
        End If
    Set rs = Nothing: Set con = Nothing
End Sub

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")


S1_son_sat = S1.[n65536].End(3).Row
S2_son_sat = S2.[n65536].End(3).Row

S1.Range("k2:k65536").ClearContents

For i = 2 To S1_son_sat
For a = 2 To S2_son_sat

If S1.Cells(i, "n") = S2.Cells(a, "n") Then

S1.Cells(i, "k") = S2.Cells(a, "k")


Else
End If
Next a
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

 

[andon]

Şu kodları bir deneyiniz;

Sub Emre()
    Dim con As Object, rs As Object
    Set con = CreateObject("adodb.connection")
    con.Open "provideR=microsoft.jet.oledb.4.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes"""
    Set rs = CreateObject("adodb.recordset")
    rs.Open "select v11 from [Sayfa2$] where exists (select v11 from [Sayfa1$] where [Sayfa2$].[v14]=[Sayfa1$].[v14])", con, 1, 1
        If rs.RecordCount > 0 Then
            Range("K2").CopyFromRecordset rs
        End If
    Set rs = Nothing: Set con = Nothing
End Sub

hocam çok tşk ederim ilginiz için ancak kodu çalışıtırdığımda hata mesajı alıyorum.

 

[Civan Jack]

Hüseyin bey'in kodunu deneyin ya da ne hatası aldığınızı belirtin ki ona göre size bir cevap verebileyim.

 

[andon]

İlginize çok teşekkür ederim. gerçekten çok makbule geçti. inanıın elimde yaklaşık 10.000 satırlık bir dosya vardı ve yetiştirmem egreken bir işti. Açık söylemem gerekirse bu kadar çabuk cevap verilmesi beni hem şaşırttı hem de mutlu etti.
Hüseyin hocanın gönderdiği kodlar çalıştı, civan hack hocanın kodunda karşıma çıkan hata kodunu da hemen göndereceğim.
saygılarımla

 

[andon]

Hüseyin bey'in kodunu deneyin ya da ne hatası aldığınızı belirtin ki ona göre size bir cevap verebileyim.

merhaba hocam
hata kodunu ekte gönderiyorum
saygılarımla

 

[andon]

. . .

Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")


S1_son_sat = S1.[n65536].End(3).Row
S2_son_sat = S2.[n65536].End(3).Row

S1.Range("k2:k65536").ClearContents

For i = 2 To S1_son_sat
For a = 2 To S2_son_sat

If S1.Cells(i, "n") = S2.Cells(a, "n") Then

S1.Cells(i, "k") = S2.Cells(a, "k")


Else
End If
Next a
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

hocam bu kodu geliştirmek adına bir sorum daha olacaktı;
sayfa1 de bulunan sarı ile taranmış bölüme verileri yazdırıyorduk. eğer veri yazdırmak istediğimiz sarı ile taranmış alanda bazı hücrelerde değer var ise onlara yazdırmayı atlatabilir miyiz?
saygılaırmla

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")


S1_son_sat = S1.[n65536].End(3).Row
S2_son_sat = S2.[n65536].End(3).Row

'S1.Range("k2:k65536").ClearContents

For i = 2 To S1_son_sat
For a = 2 To S2_son_sat

If S1.Cells(i, "K") = "" And _
S1.Cells(i, "n") = S2.Cells(a, "n") Then

S1.Cells(i, "k") = S2.Cells(a, "k")

Else
End If

Next a
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

 

[andon]

hocam teşekkür ederim. son gönderdiğiniz kodlar da işime fazlasıyla yaradı.
emeğinize sağlık. iyi çalışmalar