• DİKKAT

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

Formül yerine makro kullanımı

M

mybluecat

Katılım
19 Mayıs 2015
Mesajlar
239
Excel Vers. ve Dili
2010 türkçe
Merhaba,
Aşağıdaki formülün yaptığı işi, makro yardımıyla yapmak mümkün mü? Örnek dosyalar ekte ..

Teşekkürler ...

=EĞER(EHATALIYSA(ARA($C10;'[NUMUNE KABUL - KAYIT.xlsm]ANALİZ SONUÇLARI'!$B$5:$B$27160;'[NUMUNE KABUL - KAYIT.xlsm]ANALİZ SONUÇLARI'!$C$5:C$27160));"";ARA($C10;'[NUMUNE KABUL - KAYIT.xlsm]ANALİZ SONUÇLARI'!$B$5:$B$27160;'[NUMUNE KABUL - KAYIT.xlsm]ANALİZ SONUÇLARI'!$C$5:C$27160))
 

Ekli dosyalar

Merhaba,

ANALİZ SONUÇLARI isimli sayfanızın koruma şifresini paylaşır mısınız?
 
kaldırdığımı zannediyordum. Özür dilerim. Şifre 3452
 
Şu item için çıkış sütunu yok sanırım.

"UYA
(mg CH3COOH/L)"
 
Aşağıdaki item için sütundaki formülleriniz doğru mu?

Kontrol eder misiniz?

"OTH
(mg/L/Saat)"
 
Giriş - Çıkış isimli sayfanızın kod bölümüne uygulayıp deneyiniz.

C sütunundaki hücrelere veri girişi yaptığınızda kod çalışacaktır.

Bende tek satır veri güncellemesi yaklaşık 7 saniye sürüyor. Bunun sebebi veri alınacak diğer dosyanızda boş satırlarda 30 binli satırlara kadar formüller var. Bunları azaltma imkanınız varsa süre kısalabilir.

C++: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan As Range, Veri As Range, X As Integer
    Dim Baglanti As Object, Kayit_Seti As Object, Zaman As Double
    Dim Sorgu As String, Dosya As String, Say As Integer
    Dim Sutun As Variant, Sutun_Giris As Variant, Sutun_Cikis As Variant
    
    Set Alan = Range("C9:C" & Cells(Rows.Count, 2).End(3).Row)
    If Intersect(Target, Alan) Is Nothing Then Exit Sub
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Dosya = ThisWorkbook.Path & "\NUMUNE KABUL - KAYIT.xlsm"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sutun_Giris = Array(3, 4, 5, 6, 7, 8, 9, 10, 19, 18, 13, 14, 15, 22, 16, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38)
    Sutun_Cikis = Array(3, 4, 5, 6, 7, 8, 9, 10, 18, 13, 14, 15, 22, 16, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38)
    Sutun = Array(1, 6, 7, 8, 42)
    
    For Each Veri In Intersect(Target, Alan).Columns(1)
        If Veri.Cells(, 1) <> "" And Veri.Cells(, 2) <> "" Then
            Say = 0
            For X = 5 To 65
                If Cells(8, X) = "Giriş" Then
                    Sorgu = "Select F" & Sutun_Giris(Say) - 1 & " From [ANALİZ SONUÇLARI$B5:AL] Where F1 = '" & Veri.Cells(, 1) & "'"
            
                    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                    
                    If Kayit_Seti.RecordCount > 0 Then Cells(Veri.Row, X).CopyFromRecordset Kayit_Seti
                    
                    Say = Say + 1
                    
                    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
                End If
            Next
        
            Say = 0
            For X = 5 To 65
                If Cells(8, X) = "Çıkış" Then
                    Sorgu = "Select F" & Sutun_Cikis(Say) - 1 & " From [ANALİZ SONUÇLARI$B5:AL] Where F1 = '" & Veri.Cells(, 2) & "'"
            
                    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                    
                    If Kayit_Seti.RecordCount > 0 Then Cells(Veri.Row, X).CopyFromRecordset Kayit_Seti
                    
                    Say = Say + 1
                    
                    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
                End If
            Next
        
            Say = 0
            For X = 66 To 74 Step 2
                Sorgu = "Select F" & Sutun(Say) & " From [NUMUNE KAYIT KABUL$B6:AW] Where F5 = " & Veri.Cells(, 1) & ""
        
                Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                
                If Kayit_Seti.RecordCount > 0 Then Cells(Veri.Row, X).CopyFromRecordset Kayit_Seti
                
                Say = Say + 1
                
                If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            Next
        
            Say = 0
            For X = 67 To 73 Step 2
                Sorgu = "Select F" & Sutun(Say) & " From [NUMUNE KAYIT KABUL$B6:AW] Where F5 = " & Veri.Cells(, 2) & ""
        
                Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                
                If Kayit_Seti.RecordCount > 0 Then Cells(Veri.Row, X).CopyFromRecordset Kayit_Seti
                
                Say = Say + 1
                
                If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            Next
        End If
    Next

    If Baglanti.State <> 0 Then Baglanti.Close
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "Güncel veriler alınmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    
    Set Alan = Nothing
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
End Sub
 
Elinize sağlık. Teşekkür ederim. Verilerin gelmesi bende de 7-8 saniye sürüyor. Bu da başka bir problem. Örnek dosya da tek sekme vardı. Benim kullanacağım dosya da farklı isim ve formatlarda 10 sekme olacak. Her biri için ayrı bir kod gerekecek sanırım. Amacım 10 sekmedeki binlerce hücreye sorduğum sorudaki gibi formüller yazmadan verilerin bir şekilde gelmesini sağlamaktı. Formül ile olunca dosyanın açılması uzun sürüyor. Kod ile çabuk açılıyor ama veriler yavaş geliyor. Üçüncü bir alternatif yoksa formüller ile devam etmem gerekecek sanırım.
Tekrar teşekkürler...
 
Merhaba,

Kullandığım yöntem (ADO) dosyaları açmadan verileri çekiyor ve en hızlı yöntemlerden biridir.

Dosyalar açılarak belki dizi yöntemiyle biraz daha hız kazanılabilir.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst