ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[ahmttsezer]

Herkese merhaba,

Bir konuda desteklerinize ihtiyacım var. Şimdiden herkese teşekkür ederim.

Mevcut adlı dosyada Sipariş No(C Sütunu) aynı olup Gönderi Kodu(D Sütunu) farklı olanları Karşılaştırma dosyasına getirmek istiyorum. Mükerrer sipariş ile ilgili bir çalışma yapıyorum. Kodladım fakat yeni başladığım için kod geçerli değil. Örnek dosyayı ekte iletiyorum.

Desteklerinizi rica ederim.

[halily]

Mevcut dosyasındaki veriler mi karşılaştırma dosyasına eklenecek

[ahmttsezer]

Halil Bey merhaba,

Evet, Mevcut adlı Excel dosyasında Sipariş No aynı olup Gönderi Kodu farklı olan kayıtların Karşılaştırma dosyasında bir sayfa oluşturularak eklenmesini istiyorum.

Teşekkürler

[halily]

sorgu kodunu aşağıdaki şekilde düzenler misiniz?
yalnız gönderdiğiniz dosyalarda veriler 1e1 aynıydı
sonucun nasıl olması gerektiğini de gösterir misiniz

Kod: Tümünü seç

    sorgu = "SELECT [Mevcut$].F3, [Mevcut$].F4, [Mevcut$].F1, [Mevcut$].F2 " & _
            "FROM [Sayfa1$] INNER JOIN [Mevcut$] ON ([Sayfa1$].F1 = [Mevcut$].F3) AND ([Sayfa1$].F4 = [Mevcut$].F2) " & _
            "WHERE ((([Mevcut$].F4)<>[Sayfa1$]![F2]));"

[ahmttsezer]

Halil Bey merhaba,

Öncelikle sanırım yanlış anlattım, affedersiniz.

Mevcut adlı dosyada 150-200 bin adet kayıt bulunmakta. Bu excel dosyasındaki Sipariş No(C Sütunu) değerleri aynı olan ve Gönderi Kodu(D Sütunu) farklı olan kayıtları, Karşılaştırma dosyasındaki makroyu çalıştırdığımda Karşılaştırma dosyası Sayfa1 Tarih-Proje-Sipariş No-Gönderi kodu sütunları olarak göstermek istiyorum.

Ekte güncel halini paylaşıyorum. Sonucun nasıl olması gerektiğini de Karşılaştırma excel dosyasında Sayfa1 de görebilirsiniz.

[halily]

Siparis no 1110 dan 3 tane var 2 tanesinin gonderimkodu 56, hangisini neye gore seçiyoruz?

[ahmttsezer]

Halil Bey,

Sipariş No sütununda 1110 nolu siparişe ait Gönder Kodları birbirinden farklı olanları almasını istiyorum. Mesela Gönderi Kodu 2 tane 56, bir tane 57 var. 56 tekrarladığı için 1 tane alacak ve 57 değerini de alacak.

[halily]

aşağıdaki kodu dener misiniz?
Not: referanslardan Microsoft ActiveX Data Objects x.x Library eklenmeli

Kod: Tümünü seç

Dim RS As ADODB.Recordset
Dim con As ADODB.Connection
   
    Set con = New ADODB.Connection
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
    "\Mevcut.xlsx;extended properties=""excel 12.0;hdr=no;imex=1"""
    Set RS = New ADODB.Recordset ' CreateObject("adodb.recordset")
    sorgu = "SELECT [F3] " & _
            "FROM " & _
            "(SELECT [F3], [F4], First([F2]) as Pr, First([F1]) as Tr " & _
            "FROM [Sayfa1$] " & _
            "GROUP BY [F3], [F4]) " & _
            "as TmpSQL " & _
            "GROUP BY [F3] " & _
            "HAVING ((Count([F4]))>1);"
   
    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub
    Dim EkleDizi() As Variant
    With RS
        .MoveLast
        .MoveFirst
        EkleDizi = .GetRows()
    End With
   
    For x = LBound(EkleDizi, 2) To UBound(EkleDizi, 2)
        Kyt = Kyt & ", '" & EkleDizi(0, x) & "'"
    Next x
    Kyt = Mid(Kyt, 3)
    Set RS = Nothing: sorgu = Empty
'hy_____aşama________________________________________________________2
    Set RS = New ADODB.Recordset 'CreateObject("adodb.recordset")
    sorgu = "SELECT [F3], [F4], First([F1]) AS İlkTarih, First([F2]) AS İlkProje " & _
            "FROM [Sayfa1$] " & _
            "GROUP BY [F3], [F4] " & _
            "HAVING (([F3] In (" & Kyt & "))) " & _
            "ORDER BY [F3], [F4];"
   
    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub
    Sheets("Sayfa1").Range("a2").CopyFromRecordset RS
    Sheets("Sayfa1").Range("a1").Value = "Sipariş Numarası"
    Sheets("Sayfa1").Range("b1").Value = "Gönderi Kodları"
    Sheets("Sayfa1").Range("c1").Value = "Tarih"
    Sheets("Sayfa1").Range("d1").Value = "Proje Adı"
    Set RS = Nothing: Set con = Nothing: sorgu = Empty

[ahmttsezer]

Halil Bey,

Destekleriniz ve ilginiz için teşekkür ederim. Mevcut datam 540.000 satırdan oluşuyor. Normal ekteki datada çalışıyor fakat kendi datamda çalışmıyor. 10 dk dan fazla işlem sürüyor fakat sonuç vermiyor.

For x = LBound(EkleDizi, 2) To UBound(EkleDizi, 2)
Kyt = Kyt & ", '" & EkleDizi(0, x) & "'"
kodda uzun süre bekliyor.

Çok fazla satır olmasından dolayı mı çalışmıyor? Farklı bir kod yazılabilir mi?

Ek olarak Microsoft ActiveX Data Objects 6.1 Library ekledim.

[halily]

Verileriniz ozel değilse dosyanızın ilgili kısmını ekleyebilir misiniz?

[ahmttsezer]

Halil Bey,

Malesef şirket verileri. Uzun bir süre bekledikten sonra 'sorgu çok karmaşık' hatası verdi.

[halily]

Dilerim işinize yarar

Kod: Tümünü seç

Dim RS As ADODB.Recordset
Dim con As ADODB.Connection
   
    Set con = New ADODB.Connection
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
             "\Mevcut.xlsx;extended properties=""excel 12.0;hdr=no;imex=1"""
    Set RS = New ADODB.Recordset ' CreateObject("adodb.recordset")
    sorgu = "SELECT [F3], [F4], First([F1]), First([F2]) " & _
            "FROM [Sayfa1$A2:D] " & _
            "GROUP BY [F3], [F4];"
   
    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub

     Sheets("Sayfa1").Range("a2").CopyFromRecordset RS

Set RS = Nothing: Set con = Nothing: sorgu = Empty

'hy_____aşama2
    Set con = New ADODB.Connection
    con.Open "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
             ";extended properties=""excel 12.0;hdr=no"""
    Set RS = New ADODB.Recordset 'CreateObject("adodb.recordset")
    sorgu = "SELECT F1 " & _
            "FROM [Sayfa1$A2:D] " & _
            "GROUP BY F1 " & _
            "HAVING (((Count(F1))>1));"

    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub
    Do Until RS.EOF
        kyt = kyt & ", " & RS(0) ' & "'"
        RS.MoveNext
    Loop
   
    kyt = Mid(kyt, 3)

'hy________________Aşama3
    Set RS = New ADODB.Recordset
   
    sorgu = "SELECT F1, F2, F3, F4 " & _
            "FROM [Sayfa1$A2:D] " & _
            "WHERE (((F1) In (" & kyt & ")));"
   
    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub
    Sheets("Sayfa1").Cells.Clear
    Sheets("Sayfa1").Range("a2").CopyFromRecordset RS
    Sheets("Sayfa1").Range("a1").Value = "Sipariş Numarası"
    Sheets("Sayfa1").Range("b1").Value = "Gönderi Kodları"
    Sheets("Sayfa1").Range("c1").Value = "Tarih"
    Sheets("Sayfa1").Range("d1").Value = "Proje Adı"
    Set RS = Nothing: Set con = Nothing: sorgu = Empty

[ahmttsezer]

Halil Bey merhaba,

Çok fazla zahmet verdim, kusura bakmayın.

Sipariş Numarası kısmına metinsel değerler, _1 li kayıtlar ya da *AC*, *MF* gibi değerler girilebiliyor. Sanırım metinsel ifadeler yer aldığından ekteki hatayı veriyor. Dosya ile birlikte hata kodunu içeren görseli de iletiyorum.

Tekrar zahmet verdiğim için kusura bakmayın.

[halily]

* karakteri joker karakterdir [b]in içinde kullanılamaz[/b]
2. olarak çalışmanızda hep sayısal veri olduğu için ben IN fonksiyonunu sayaısal olarak ayarlamıştım
metinsel ifadelerin başında ve sonunda ' tek tırnak yada "" çift çift tırnak olmalı

[halily]

Kod: Tümünü seç

kyt = kyt & ", " & RS(0)

yerine

Kod: Tümünü seç

kyt = kyt & ", '" & RS(0)  & "'"

kullanarak dener misiniz

[ahmttsezer]

Halil Bey merhaba,

Desteğiniz için teşekkür ederim, işe yaradı çalışıyor.

Fakat metin ile başlayan sipariş numaralarını almıyor. Kodda ne gibi bir değişiklik yapmak gerekir? Desteğinizi rica ederim.

[ahmttsezer]

Halil Bey,

Üst mesajınızda fonksiyon ile bildiriminizi yeni gördüm. Sipariş numarası serbest formattan oluşuyor, metinsel sayısal ve birleşik noktalama işaretlerini de barındıran kayıtlar mevcut olabliyor. Fonksiyonu nasıl değiştirebiliriz. Desteklerinizi rica ederim.

[halily]

Kod: Tümünü seç

kyt = kyt & ", """ & RS(0) & """"

sipariş no da " yoksa sorunsuz çalışması gerek.

[halily]

aşağıdaki kodun daha hızlı çalışacağını düşünüyorum
ama deneme imkanım yok

Kod: Tümünü seç

Dim RS As ADODB.Recordset
Dim con As ADODB.Connection
   
    Set con = New ADODB.Connection
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
             "\Mevcut.xlsx;extended properties=""excel 12.0;hdr=no;imex=1"""
    Set RS = New ADODB.Recordset ' CreateObject("adodb.recordset")
    sorgu = "SELECT [F3], [F4], First([F1]), First([F2]) " & _
            "FROM [Sayfa1$A2:D] " & _
            "GROUP BY [F3], [F4];"
   
    RS.Open sorgu, con, 3, 1
    If RS.RecordCount = 0 Then Exit Sub

     Sheets("Sayfa1").Range("a2").CopyFromRecordset RS

Set RS = Nothing: Set con = Nothing: sorgu = Empty

'hy_____aşama2
    Dim sht As Worksheet
    Dim dict As Scripting.Dictionary
    Set dict = New Scripting.Dictionary
    Set sht = ThisWorkbook.Sheets("Sayfa1")
    SonStr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    For i = 2 To SonStr
        kriter = sht.Cells(i, 1)
       
        If Not dict.Exists(kriter) Then
           dict.Add kriter, 1
        Else
            dict(kriter) = dict.Item(kriter) + 1
        End If
    Next
'tekrar kontrolü
    For i = SonStr To 2 Step -1
        kriter = sht.Cells(i, 1)
        If dict(kriter) = 1 Then Rows(i).EntireRow.Delete
    Next

[halily]

pardon söylemeyi unutmuşum referanslardan Microsoft Scripting Runtime eklenmeli