• DİKKAT

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

Formülün VBA koda çevrilmesi

  • Konbuyu başlatan Konbuyu başlatan endexci
  • Başlangıç tarihi Başlangıç tarihi
E

endexci

Altın Üye
Katılım
27 Ağustos 2011
Mesajlar
67
Excel Vers. ve Dili
2010 türkçe
Merhabalar,

Excelde A ve B sütunlarımda değerler var, aşağıdaki formül ile benzersizleri saydırıyorum fazla veri olmayınca sorun yok çalışıyor formüller, fakat 50 bin satırda kasma yaptırıyor. Formülümü VBA koduna çevirmek istedim kasmadan benzersizleri saydırması için, fakat yapamadım konu ile ilgili yardımcı olur musunuz yada yazdığım formülde hata mı var değerli görüşlerinizi sabırsızlıkla bekliyorum. Şimdiden teşekkür ederim.

TOPLA(EĞER(SIKLIK(EĞER((Sayfa1!$B$2:$B$66141<>"")*(Sayfa1!$A$2:$A$66141=Sayfa1!$A8);KAÇINCI("~"&Sayfa1!$B$2:$B$66141;Sayfa1!$B$2:$B$66141&"";0));SATIR(Sayfa1!$B$2:$B$66141)-SATIR($B$2)+1);1))
 

Ekli dosyalar

Formülün ne işe yaradığını bilmiyorum. Ama aşağıdaki kod sipariş numarasına göre, farklı ürünleri sayar.

Kod: 
Sub test()
    Dim veri, i&, ky, kys, rng As Range, krt

    With Sheets("Sayfa1")
        Set rng = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row)
        veri = rng.Value
    End With

    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(veri)
            .Item(veri(i, 1) & "|" & veri(i, 2)) = Null
        Next i
        
        kys = .keys
        .RemoveAll
        
        For Each ky In kys
            krt = Val(Split(ky, "|")(0))
            .Item(krt) = .Item(krt) + 1
        Next
        
        For i = 1 To UBound(veri)
            veri(i, 3) = .Item(veri(i, 1))
        Next i
        
        rng.Value = veri
        
    End With

End Sub
 
veyselemre' Alıntı:
Formülün ne işe yaradığını bilmiyorum. Ama aşağıdaki kod sipariş numarasına göre, farklı ürünleri sayar.

Kod: 
Sub test()
    Dim veri, i&, ky, kys, rng As Range, krt

    With Sheets("Sayfa1")
        Set rng = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row)
        veri = rng.Value
    End With

    With CreateObject("Scripting.Dictionary")
       
        For i = 1 To UBound(veri)
            .Item(veri(i, 1) & "|" & veri(i, 2)) = Null
        Next i
       
        kys = .keys
        .RemoveAll
       
        For Each ky In kys
            krt = Val(Split(ky, "|")(0))
            .Item(krt) = .Item(krt) + 1
        Next
       
        For i = 1 To UBound(veri)
            veri(i, 3) = .Item(veri(i, 1))
        Next i
       
        rng.Value = veri
       
    End With

End Sub
Genişletmek için tıkla ...



Çok teşekkür ederim ALLAH razı olsun tam istediğim gibi çalıştı
 
Alternatif,

ADO uygulaması...

C++: 
Option Explicit

Sub Benzersiz_Say_Ado()
    Dim My_Connection As Object, My_Recordset As Object, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Range("C2:C" & Rows.Count).ClearContents
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
     
    Set My_Recordset = My_Connection.Execute("Select Tablo_2.Adet From " & _
                                             "[Sayfa1$] As Tablo_1 Left Join " & _
                                             "(Select [Sipariş Numarası],Count([Sipariş Numarası]) As Adet From " & _
                                             "(Select Distinct [Sipariş Numarası],[Ürün Adı] From [Sayfa1$]) " & _
                                             "Group By [Sipariş Numarası]) As Tablo_2 " & _
                                             "On Tablo_1.[Sipariş Numarası] = Tablo_2.[Sipariş Numarası]")

    If Not My_Recordset.EOF Then Range("C2").CopyFromRecordset My_Recordset

    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Set My_Connection = Nothing
    Set My_Recordset = Nothing

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif,

ADO uygulaması...

C++: 
Option Explicit

Sub Benzersiz_Say_Ado()
    Dim My_Connection As Object, My_Recordset As Object, Process_Time As Double
   
    Process_Time = Timer
   
    Application.ScreenUpdating = False
   
    Range("C2:C" & Rows.Count).ClearContents
   
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")

    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
    
    Set My_Recordset = My_Connection.Execute("Select Tablo_2.Adet From " & _
                                             "[Sayfa1$] As Tablo_1 Left Join " & _
                                             "[B](Select [Sipariş Numarası],Count([Sipariş Numarası]) As Adet From " & _
                                             "(Select Distinct [Sipariş Numarası],[Ürün Adı] From [Sayfa1$]) " & _
                                             "Group By [Sipariş Numarası])[/B] As Tablo_2 " & _
                                             "On Tablo_1.[Sipariş Numarası] = Tablo_2.[Sipariş Numarası]")

    If Not My_Recordset.EOF Then Range("C2").CopyFromRecordset My_Recordset

    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
 
    Set My_Connection = Nothing
    Set My_Recordset = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...

Korhan Hocam merhaba,
Burada vermiş olduğunuz ADO uygulamasıyla ilgili bir şey sormak istiyorum? ne derece olabilir, işin doğrusu merka ediyorum.

görüleceği üzere sorgu içinde sorgu mevcut; Ana sorgunun içindeki yardımcı sorguyu öncesinde farklı bir Recorset Kayıt Kümesi içine alsak;

strSQL= (Select [Sipariş Numarası],Count([Sipariş Numarası]) As Adet From " & _
"(Select Distinct [Sipariş Numarası],[Ürün Adı] From [Sayfa1$]) " & _
"Group By [Sipariş Numarası])

Set My_RS = My_Connection.Execute(strSQL)

yada;

My_RS.open strSQL, My_Connection

sonra bu My_RS Kayıt Kümesi içinden sorgulatmak mümkün olur mu?
Bazen bu kayıtları sayfaya yazdırdıktan sonra devam ediyorum, sayfaya yazdırmdadan kestirmeden mümkün olur mu diye düşündüm.

teşekkürler, iyi Çalışmalar.
 
Merhaba Tamer Bey,

Benim bildiğim SubQuery (Alt Sorgu) ile olabildiğidir. Ya da sizin belirttiğiniz gibi sorgu sonucunu sayfaya yazdırıp oradan diğer sorguları yürüterek sonuca gidilebilir.

Belki ilk sorgu sonucu diziye alınarak sonuca gidilebilir. Bu konuda tecrübeli üyelerimiz bizleri yönlendirebilirler.
 
Korhan Ayhan' Alıntı:
Merhaba Tamer Bey,

Benim bildiğim SubQuery (Alt Sorgu) ile olabildiğidir. Ya da sizin belirttiğiniz gibi sorgu sonucunu sayfaya yazdırıp oradan diğer sorguları yürüterek sonuca gidilebilir.

Belki ilk sorgu sonucu diziye alınarak sonuca gidilebilir. Bu konuda tecrübeli üyelerimiz bizleri yönlendirebilirler.
Genişletmek için tıkla ...

hOR
Korhan Ayhan' Alıntı:
Alternatif,

ADO uygulaması...
Genişletmek için tıkla ...
Korhan Hocam merhaba,
buradaki koddan esinlerek ekli dosyada yer aldığı şekilde bir kod hazırladım, yalnız hata verdi.
burada nasıl bir yol takip edilebilir?

Kod: 
     strSQL3 = "Select [Kod],[Adet] From [Sayfa3$]"
     
    strSQL = "Select Tablo_3.[Adet] From " & _
               "[Sayfa2$] As Tablo_2 Left Join " & strSQL3 & " As Tablo_3 " & _
                   "On Tablo_2.[Kod] = Tablo_3.[Kod]"

                                             
         Set My_Recordset = My_Connection.Execute(strSQL)

şimdiden teşekkürker,
iyi Çalışmalar.
 

Ekli dosyalar

Alt sorgu parantez içinde olmalıdır.

strSQL3 = "(Select [Kod],[Adet] From [Sayfa3$])"
 
Korhan Ayhan' Alıntı:
Alt sorgu parantez içinde olmalıdır.

strSQL3 = "(Select [Kod],[Adet] From [Sayfa3$])"
Genişletmek için tıkla ...
Korhan hocam teşekkürler,
aslında parantez içine almak aklıma da gelmişti,

Konuyu bir adım ileriye taşımak istersek;
Sayfa1 de yer alan şehir bilgisinin karşında Sayfa2' de bir Kod var.
Sayfa2 de yer alan kod bilgisinin karşında Sayfa3' de bir Adet var.
Şehir >>> Kod >>> Adet
Sayfa1' de Şehir başlayarak Sayfa3' deki Adet bilgisine ulaşmayı düşünüyordum, Bunun için aşağıdaki sorgu düzenini oluşturdum buraya kadar sıkıntı yok;
Öğrenmeye çalıştığım Sayfa1 farklı bir dosya (Hedef) , Sayfa2 ve Sayfa3 farklı bir dosyada (Kaynak) olursa;

Hedef.xlsm dosyasından Kaynak.xls dosyasına ulaşıp aynı şekilde Adet verilerine ulaşmak için sorguyu nasıl düzenleyebiliriz?

Not: Her iki dosyada aynı klasör altında;

Kod: 
        strSQL2 = "(Select Tablo_2.[Kod] From " & _
               "[Sayfa1$] As Tablo_1 Left Join [Sayfa2$] As Tablo_2 " & _
                   "On Tablo_1.[Şehir] = Tablo_2.[Şehir])"

     strSQL3 = "(Select [Kod],[Adet] From [Sayfa3$])"
     
    strSQL = "Select Tablo_3.[Adet] From " & _
               strSQL2 & " As Tablo_2 Left Join " & strSQL3 & " As Tablo_3 " & _
                   "On Tablo_2.[Kod] = Tablo_3.[Kod]"
                      
         Set My_Recordset = My_Connection.Execute(strSQL)

ilginize tekrar teşekkürler,
iyi akşamlar.
 

Ekli dosyalar

Bu linkte örnekler var. Sanırım kendinize uyarlayabilirsiniz.

Soru - Düşeyara (VBA ile Dış Kaynaktan)

Değerli üstadlar; Excel içinde düşeyara gerek formülle, gerek makro ile yapabilmekteyim. Merak ettiğim VBA yolu ile "Hedef Excel" e "Kaynak Excel" den düşeyara ile veri çektirebilir miyiz?
www.excel.web.tr www.excel.web.tr
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst