• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çözüldü Kapalı Sayfalardan Belirtilen Koşulla Göre Veri Aktarmak.

Sayfa1 ve Sayfa2 ID lerini karşılaştırıp Sayfa3 e farklarını yazacak, Zeki Beyin kodları kadar hızlı değil ama şimdilik idare eder.
Bu arada bence siz SQL üzerinden direkt olarak sorguları yapmaya yoğunlaşın, ben de fazla sql bilmiyorum ama deneme yanılmayla yazdım.
Kod: 
Sub adoListele()
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("ADODB.Recordset")

    strsql = "SELECT [Sayfa1$].ID  FROM [Sayfa1$] LEFT JOIN [Sayfa2$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa2$].ID Is Null "

    rs.Open strsql, adoCN, 1, 1

    Sheets("Sayfa3").UsedRange.ClearContents
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("A2").CopyFromRecordset rs
    rs.Close

    strsql = "SELECT [Sayfa2$].ID  FROM [Sayfa2$] LEFT JOIN [Sayfa1$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa1$].ID Is Null "
    rs.Open strsql, adoCN, 1, 1
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("B2").CopyFromRecordset rs
    rs.Close
  
    adoCN.Close
End Sub
 
Son düzenleme:
veyselemre' Alıntı:
Sayfa1 ve Sayfa2 ID lerini karşılaştırıp Sayfa3 e farklarını yazacak, Zeki Beyin kodları kadar hızlı değil ama şimdilik idare eder.
Bu arada bence siz SQL üzerinden direkt olarak sorguları yapmaya yoğunlaşın, ben de fazla sql bilmiyorum ama deneme yanılmayla yazdım.
Kod: 
Sub adoListele()
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("ADODB.Recordset")

    strsql = "SELECT [Sayfa1$].ID  FROM [Sayfa1$] LEFT JOIN [Sayfa2$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa2$].ID Is Null "

    rs.Open strsql, adoCN, 1, 1

    Sheets("Sayfa3").UsedRange.ClearContents
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("A2").CopyFromRecordset rs
    rs.Close

    strsql = "SELECT [Sayfa2$].ID  FROM [Sayfa2$] LEFT JOIN [Sayfa1$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa1$].ID Is Null "
    rs.Open strsql, adoCN, 1, 1
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("B2").CopyFromRecordset rs
    rs.Close
 
    adoCN.Close
End Sub
Genişletmek için tıkla ...
Kod: 
Sub adoListele()
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("ADODB.Recordset")
 
    strsql = "SELECT [Sayfa1$].ID  FROM [Sayfa1$] LEFT JOIN [Sayfa2$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa2$].ID Is Null "
 
    rs.Open strsql, adoCN, 1, 1

    Sheets("Sayfa3").UsedRange.ClearContents
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("A2").CopyFromRecordset rs
    rs.Close
    
    
    strsql = "SELECT [Sayfa2$].ID  FROM [Sayfa2$] LEFT JOIN [Sayfa1$] ON [Sayfa1$].ID = [Sayfa2$].ID WHERE [Sayfa1$].ID Is Null "
    rs.Open strsql, adoCN, 1, 1
    If rs.RecordCount > 0 Then Sheets("Sayfa3").Range("B2").CopyFromRecordset rs
    rs.Close
    
    adoCN.Close
End Sub
Biryerde hata vardı düzeltme yaptım. Çok hızlı oldu. teşekkürler. Fakat sadece sayısal değerleri karşılaştırmasının sebebini anlayamadım?
 
Veysel Beyin önerisinin bende çalışan şekli şöyle;

Kod: 
Sub Test()
    'Haluk - 08/03/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim adoCN As Object
    Dim RS As Object
   
    Const adOpenKeyset = 1
   
    Sheets("Sayfa3").Range("A1:A" & Rows.Count) = Empty
   
    Set adoCN = CreateObject("ADODB.Connection")
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
   
    Set RS = CreateObject("ADODB.Recordset")
   
    ' Asagidaki sorguda; [VERGIDAIRE$].ID alaninda olup, [Sayfa1$].ID alaninda olmayan kayitlar
    ' NULL olarak doner. Biz de, bu kayitlari ariyoruz....
   
    strSQL = "Select [VERGIDAIRE$].ID From [VERGIDAIRE$] " _
           & "Left Join [Sayfa1$] On [Sayfa1$].ID = [VERGIDAIRE$].ID " _
           & "Where [Sayfa1$].ID Is Null"
          
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
   
    Sheets("Sayfa3").Range("A1") = RS.Fields(0).Name
    Sheets("Sayfa3").Range("A2").CopyFromRecordset RS
   
    RS.Close
    adoCN.Close
    Set RS = Nothing
    Set adoCN = Nothing
End Sub
 
Son düzenleme:
Haluk' Alıntı:
Veysel Beyin önerisinin bende çalışan şekli şöyle;

Kod: 
Sub Test()
    'Haluk - 08/03/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim adoCN As Object
    Dim RS As Object
  
    Const adOpenKeyset = 1
  
    Sheets("Sayfa3").Range("A1:A" & Rows.Count) = Empty
  
    Set adoCN = CreateObject("ADODB.Connection")
  
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
  
    Set RS = CreateObject("ADODB.Recordset")
  
    ' Asagidaki sorguda; [VERGIDAIRE$].ID alaninda olup, [Sayfa1$].ID alaninda olmayan kayitlar
    ' NULL olarak doner. Biz de, bu kayitlari ariyoruz....
  
    strSQL = "Select [VERGIDAIRE$].ID From [VERGIDAIRE$] " _
           & "Left Join [Sayfa1$] On [Sayfa1$].ID = [VERGIDAIRE$].ID " _
           & "Where [Sayfa1$].ID Is Null"
         
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
  
    Sheets("Sayfa3").Range("A1") = RS.Fields(0).Name
    Sheets("Sayfa3").Range("A2").CopyFromRecordset RS
  
    RS.Close
    adoCN.Close
    Set RS = Nothing
    Set adoCN = Nothing
End Sub
Genişletmek için tıkla ...

Haluk bey burada sorgulamayı iki taraflıyapmak için aynı kodları bir de tersten mi yazmak gerekecek?
 
Genelde öyle çift taraflı sorgulama yapmak gibi bir şey pek olmaz veri tabanı işlerinde ama; hangi tabloyu esas alacağınıza göre, kodda alan adlarını değiştirerek kullanabilirsiniz tabii...

Sizin ne yapmak istediğinizi tam bilmiyorum.... yoksa siz 2 listeyi birleştirip, buradan sadece benzersiz kayıtlar içeren bir final listesi mi yapmaya çalışıyorsunuz?
.
 
Haluk' Alıntı:
Genelde öyle çift taraflı sorgulama yapmak gibi bir şey pek olmaz veri tabanı işlerinde ama; hangi tabloyu esas alacağınıza göre, kodda alan adlarını değiştirerek kullanabilirsiniz tabii...

Sizin ne yapmak istediğinizi tam bilmiyorum.... yoksa siz 2 listeyi birleştirip, buradan sadece benzersiz kayıtlar içeren bir final listesi mi yapmaya çalışıyorsunuz?
.
Genişletmek için tıkla ...

Ben örnek olacak kodlardan kendim gideceğimi düşünerek tam ifade edemedim sanırım.

İki sayfayı karşılaştırıp misal birsayfaya sayfa1de olup sayfa2de olmayanlar diğer sayfaya da sayfa2de olup sayfa1de olmayanlar gelmesi grekiyor. #121 nolu mesajda aslında çok çok hızlı bir sonuç aldım.
Düzeltmesi #122 nolu mesajda olan kodlar.
 
O zaman probleminiz çözülmüş durumda ... öyle değil mi?

.
 
Haluk' Alıntı:
O zaman probleminiz çözülmüş durumda ... öyle değil mi?

.
Genişletmek için tıkla ...
Evet.
Ama Diğer kodların kullanım şeklini merak etttim. 4 kitabı accese aktarıp oradan karşılaştırıp bu işi 47 saniyede yapan kodları :)

48nolu mesaj
 
Sayfa3' e

A sütununa sayfa1 de olmayanlar listelendi.

C sütununa "VERGİDAİRE" de olmayanlar listendi.

Eğer sizi doru anladım ise.

Sonuç: 13sn


Kod: 
Sub test()
Z = TimeValue(Now)
a = [Tablo_CITY_Genius3_CARD].Value
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            krt = CStr(a(i, 1))
            d(krt) = krt
        Next i
b = [Tablo_CITY_Genius3_CUSTOMER_EXTENSION].Value
ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If Not d.exists(krt) Then
            say = say + 1
            c(say, 1) = krt
        End If
        d1(krt) = krt
    Next i

ReDim c1(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If Not d1.exists(krt) Then
            sat = sat + 1
            c1(sat, 1) = krt
        End If
    Next i
    With Sheets("Sayfa3")
        .[A2].Resize(say).NumberFormat = "@"
        .[C2].Resize(sat).NumberFormat = "@"
        .[A2].Resize(say) = c
        .[C2].Resize(sat) = c1
    End With
MsgBox CDate(TimeValue(Now) - Z), vbInformation
End Sub
 
Kod: 
Sub test()
    Set s3 = Sheets("Sayfa3")
    lst1 = [Tablo_CITY_Genius3_CARD[ID]].Value
    lst2 = [Tablo_CITY_Genius3_CUSTOMER_EXTENSION[ID]].Value
    mx = IIf(UBound(lst1) > UBound(lst2), UBound(lst1), UBound(lst2))
    With CreateObject("Scripting.Dictionary")
        ReDim w(1 To mx, 1 To 2)
        For i = 1 To UBound(lst1)
            .Add CStr(lst1(i, 1)), Empty
        Next i
        For i = 1 To UBound(lst2)
            ky = CStr(lst2(i, 1))
            If .exists(ky) Then
                .Remove ky
            Else
                say2 = say2 + 1
                w(say2, 2) = ky
            End If
        Next i
        If .Count > 0 Then
            For Each ky In .keys
                say1 = say1 + 1
                w(say1, 1) = ky
            Next ky
        End If
    End With
    s3.Cells.ClearContents
    mx = IIf(say1 > say2, say1, say2)
    If say1 + say2 > 0 Then
        With s3.[a2].Resize(mx, 2)
            .NumberFormat = "@"
            .Value = w
        End With
        MsgBox "İşlem Tamam..."
        Else
        MsgBox "Eşleşmeyen Kayıt Bulunamadı..."
    End If
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub test()
    Set s3 = Sheets("Sayfa3")
    lst1 = [Tablo_CITY_Genius3_CARD[ID]].Value
    lst2 = [Tablo_CITY_Genius3_CUSTOMER_EXTENSION[ID]].Value
    mx = IIf(UBound(lst1) > UBound(lst2), UBound(lst1), UBound(lst2))
    With CreateObject("Scripting.Dictionary")
        ReDim w(1 To mx, 1 To 2)
        For i = 1 To UBound(lst1)
            .Add CStr(lst1(i, 1)), Empty
        Next i
        For i = 1 To UBound(lst2)
            ky = CStr(lst2(i, 1))
            If .exists(ky) Then
                .Remove ky
            Else
                say2 = say2 + 1
                w(say2, 2) = ky
            End If
        Next i
        If .Count > 0 Then
            For Each ky In .keys
                say1 = say1 + 1
                w(say1, 1) = ky
            Next ky
        End If
    End With
    s3.Cells.ClearContents
    mx = IIf(say1 > say2, say1, say2)
    If say1 + say2 > 0 Then
        With s3.[a2].Resize(mx, 2)
            .NumberFormat = "@"
            .Value = w
        End With
        MsgBox "İşlem Tamam..."
        Else
        MsgBox "Eşleşmeyen Kayıt Bulunamadı..."
    End If
End Sub
Genişletmek için tıkla ...
Teşekkür ederim oldukça hızlı oldu çalışma.
 
Ziynettin' Alıntı:
Sayfa3' e

A sütununa sayfa1 de olmayanlar listelendi.

C sütununa "VERGİDAİRE" de olmayanlar listendi.

Eğer sizi doru anladım ise.

Sonuç: 13sn


Kod: 
Sub test()
Z = TimeValue(Now)
a = [Tablo_CITY_Genius3_CARD].Value
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            krt = CStr(a(i, 1))
            d(krt) = krt
        Next i
b = [Tablo_CITY_Genius3_CUSTOMER_EXTENSION].Value
ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If Not d.exists(krt) Then
            say = say + 1
            c(say, 1) = krt
        End If
        d1(krt) = krt
    Next i

ReDim c1(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If Not d1.exists(krt) Then
            sat = sat + 1
            c1(sat, 1) = krt
        End If
    Next i
    With Sheets("Sayfa3")
        .[A2].Resize(say).NumberFormat = "@"
        .[C2].Resize(sat).NumberFormat = "@"
        .[A2].Resize(say) = c
        .[C2].Resize(sat) = c1
    End With
MsgBox CDate(TimeValue(Now) - Z), vbInformation
End Sub
Genişletmek için tıkla ...


Ziynettin bey teşekkür ederim.
VeyselEmre bey ile sizin kodları Karşılaştırma yaptım.

veysel bey 7 sn. ile sizin kodlarınız ile 14s. de bitti eşleştirme.
Ellerinize sağlık.
 
acar6783' Alıntı:
Evet.
Ama Diğer kodların kullanım şeklini merak etttim. 4 kitabı accese aktarıp oradan karşılaştırıp bu işi 47 saniyede yapan kodları :)

48nolu mesaj
Genişletmek için tıkla ...


Söz konusu uyarlamayı yaptım ama sonuç beklediğiniz gibi olmadı maalesef. Kodların çalışması benim bilgisayarda bu kod da 47 saniye sürdü...

Eğer @Zeki Gürsoy üstat dosyaya göz atabilirse, önerisi olabilir.

Ekli dosyalardan, Data.xlsx dosyası verilerin olduğu dosya. Bu dosya kapalı durumdayken, aynı klasöre yerleştireceğiniz Test_HD.xlsm dosyasını açıp, sayfanın üzerindeki butona tıklayarak kodu çalıştırabilirsiniz.

Dosyanın linki:

https://drive.google.com/open?id=1T9SmC85mijzI081I5v0VePDj5W8fYI3k
.
 
Haluk' Alıntı:
Söz konusu uyarlamayı yaptım ama sonuç beklediğiniz gibi olmadı maalesef. Kodların çalışması benim bilgisayarda bu kod da 47 saniye sürdü...

Eğer @Zeki Gürsoy üstat dosyaya göz atabilirse, önerisi olabilir.

Ekli dosyalardan, Data.xlsx dosyası verilerin olduğu dosya. Bu dosya kapalı durumdayken, aynı klasöre yerleştireceğiniz Test_HD.xlsm dosyasını açıp, sayfanın üzerindeki butona tıklayarak kodu çalıştırabilirsiniz.

Dosyanın linki:

https://drive.google.com/open?id=1T9SmC85mijzI081I5v0VePDj5W8fYI3k
.
Genişletmek için tıkla ...
Teşekkür ederim Haluk bey bu konuyla birlikte alternatif kodlar tanımış olduk. Bence arşivlik kodlar ortaya çıktı.

Sanırım şu an için en hızlı kodlar 7 saniye ile 130 nolu mesajdaki Veysel beyin paylaşmış olduğu kodlar oldu.

Kodların neyinasıl yaptığına ait açıklamalar yapılıp paylaşılırsa daha çok arkadaşımız işin mantığına vararak öğrenmiş olur kanısındayım.

Herşey için teşekkürler.
 
Ekli dosyada bu sefer Insert Into metodu kullanıldı. Kodların çalışması 46 saniye sürüyor, sadece 1 saniye düştü....

.
 

Ekli dosyalar

Haluk' Alıntı:
Zeki Bey;

"CopyFromRecordset" metodu 64 Bit Office'de 65.536 satırdan fazla veriyi işleyebiliyor mu? Merak ettim .... Çünkü @gicimi 100-150.000 veri ile çalışacakmış.

.
Genişletmek için tıkla ...
Merhaba.
Abey bugün bu olayı ben test etmiştim.
Eğer sayfa başlıklar 1.satırda olursa ve [Sayfa1$] olursa sorun olmuyor yani 65536dan sonrasıda geliyor hdr yes yada no olması farketmiyor.
Lakin [Sayfa1$A1:A100000] gibi olursa 65536 dan sonrası gelmiyor.
Bu sorunun çözümü varmı onuda bilmiyorum keşke.Çünkü ben 8.Satırdan itibaren yapmıştım kendi dosyamdaki verileri.Bu konu ile alakası yok yani.
Saygılar.
 
Sorgu satırında sayfa adını kaldırırsanız sonuç alabiliyorsunuz.

Sorgu = "Select F1 From [A8:A250000]"
 
Korhan Ayhan' Alıntı:
Sorgu satırında sayfa adını kaldırırsanız sonuç alabiliyorsunuz.

Sorgu = "Select F1 From [A8:A250000]"
Genişletmek için tıkla ...
Hocam sayfa ad girilmezse nasıl sayfayı tanıtacağız.Denememde çalışıyor ve anladıpım ilk sayfadaki verileri baz alıyor değil mi?
 
Veri alınacak sayfanın ilk sırada olması şartı var sanırım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst