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

veyselemre · 8 Mart 2019

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

acar6783 · 8 Mart 2019

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

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?

Haluk · 8 Mart 2019

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

acar6783 · 8 Mart 2019

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

Haluk bey burada sorgulamayı iki taraflıyapmak için aynı kodları bir de tersten mi yazmak gerekecek?

Haluk · 8 Mart 2019

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?
.

acar6783 · 8 Mart 2019

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?
.

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.

Haluk · 8 Mart 2019

O zaman probleminiz çözülmüş durumda ... öyle değil mi?

.

acar6783 · 8 Mart 2019

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

.

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

Ziynettin · 8 Mart 2019

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

veyselemre · 9 Mart 2019

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

acar6783 · 9 Mart 2019

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

Teşekkür ederim oldukça hızlı oldu çalışma.

acar6783 · 9 Mart 2019

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

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.

Haluk · 9 Mart 2019

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

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
.

acar6783 · 9 Mart 2019

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
.

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.

Haluk · 9 Mart 2019

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

.

acar6783 · 9 Mart 2019

Benim pcde bu kadar sürdü.

FERAZ · 4 Ocak 2021

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ış.

.

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.

Korhan Ayhan · 4 Ocak 2021

Sorgu satırında sayfa adını kaldırırsanız sonuç alabiliyorsunuz.

Sorgu = "Select F1 From [A8:A250000]"

FERAZ · 4 Ocak 2021

Korhan Ayhan' Alıntı:
Sorgu satırında sayfa adını kaldırırsanız sonuç alabiliyorsunuz.

Sorgu = "Select F1 From [A8:A250000]"

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?

Korhan Ayhan · 4 Ocak 2021

Veri alınacak sayfanın ilk sırada olması şartı var sanırım.

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

veyselemre

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Ziynettin

Destek Ekibi

veyselemre

Özel Üye

acar6783

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

Ekli dosyalar

acar6783

FERAZ

Korhan Ayhan

Administrator

FERAZ

Korhan Ayhan

Administrator