Formül yerine makro kullanımı

[mybluecat]

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))

 

[Korhan Ayhan]

Merhaba,

ANALİZ SONUÇLARI isimli sayfanızın koruma şifresini paylaşır mısınız?

 

[mybluecat]

kaldırdığımı zannediyordum. Özür dilerim. Şifre 3452

 

[Korhan Ayhan]

Şu item için çıkış sütunu yok sanırım.

"UYA
(mg CH3COOH/L)"

 

[mybluecat]

Evet onun için yok.

 

[Korhan Ayhan]

Aşağıdaki item için sütundaki formülleriniz doğru mu?

Kontrol eder misiniz?

"OTH
(mg/L/Saat)"

 

[mybluecat]

Hatalı olmuş evet. Düzeltip ekledim dosyayı tekrar

 

[Korhan Ayhan]

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.

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

 

[mybluecat]

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

 

[Korhan Ayhan]

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.