• DİKKAT

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

İki Koşullu Veri Aktarma

M

MrExcelMr

Katılım
2 Eylül 2019
Mesajlar
130
Excel Vers. ve Dili
2010-2013-2017 Eng.
Merhaba,

Ekteki excel çalışmasında Data sayfasında F/G sütunlarında bulunan bilgilere göre, Kodlar sayfasındaki Açıklama sütunundaki veriyi Data sayfasının M sütununa aktarmasını yapmak istiyoruz. Siz değerli uzman arkadaşlarımızdan destek bekliyoruz.

Kod sayfasında 100 satır.
Data sayfasında 25.000 ile 75.000 satır veri bulunmaktadır.

Daha farklı şekilde işlem yapılabilir ise, excel kitabında değişiklikler yapılabilir. Örneğin, Sayfalar ayrı kitaplarda olabilir.

ÖRNEK EXCEL

Data Sayfası,
3hNGH.jpg


Kodlar Sayfası,
3hmGt.jpg


Sağlıklı günler dileriz.
 
M2 ye kopyalatın aşağı doğru çoğaltabilirsiniz
=KAYDIR(Kodlar!$A$1;KAÇINCI(F2;Kodlar!$A$1:$A$75000;0)+G2-2;2;1;1)
 
@ÖmerFaruk Bey formül için teşekkür ederim. Makroya ihtiyaç duyuyoruz. sütun sayıları her geçen gün artıyor. Excelin donmaması için.
 
Hızına bakarsınız.
Yavaşsa hızlandıralım.
C++: 
Sub Açıklama()
Dim Bul As Range, i As Long
    For i = 2 To Range("F" & Rows.Count).End(3).Row
        Set Bul = Sheets("Kodlar").Range("A:A" & sonB).Find(Range("F" & i), , xlValues, xlWhole)
        Range("M" & i) = Sheets("Kodlar").Range("C" & Bul.Row + Range("G" & i) - 1)
    Next i
End Sub
 
@ÖmerFaruk Bey hızlandırmak gerekiyor. 75.000 satırda denedim. Excel dondu ve sonuçlar geç geldi. Kusura bakmayın uğraştırıyorum sizi.
 
Böyle denermisin.
C++: 
Sub Açıklama()
Dim Bul As Range, i As Long, k As Long
Dim AraList(), KodList()
Dim Zaman As Double
    Zaman = Timer
    AraList = Range("F2:G" & Range("F1").End(4).Row).Value
    KodList = Sheets("Kodlar").Range("A2:C" & Sheets("Kodlar").Range("A1").End(4).Row).Value   
    For i = LBound(AraList, 1) To UBound(AraList, 1)
        For k = LBound(KodList, 1) To UBound(KodList, 1)
            If KodList(k, 1) = AraList(i, 1) And KodList(k, 2) = AraList(i, 2) Then
                Range("M" & i + 1) = KodList(k, 3)
                Exit For
            End If
        Next k
    Next i
    MsgBox "Toplam Süre : " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Hız açısından farkına bakmak için bunu da deneyin.
Her ikisinin de sürelerini belirtirseniz çok makbule geçecek.

C++: 
Sub Açıklama2()
Dim Bul As Range, i As Long, k As Long, x as lonng
Dim AraList(), KodList(), NList()
Dim Zaman As Double
    Zaman = Timer
    AraList = Range("F2:G" & Range("F1").End(4).Row).Value
    KodList = Sheets("Kodlar").Range("A2:C" & Sheets("Kodlar").Range("A1").End(4).Row).Value
    ReDim NList(1 To UBound(AraList, 1))
   
    For i = LBound(AraList, 1) To UBound(AraList, 1)
        For k = LBound(KodList, 1) To UBound(KodList, 1)
            If KodList(k, 1) = AraList(i, 1) And KodList(k, 2) = AraList(i, 2) Then
                x = x + 1
                NList(x) = KodList(k, 3)
                Exit For
            End If
        Next k
    Next i
    Range("M2:M" & Range("F1").End(4).Row) = Application.Transpose(NList)
    MsgBox "Toplam Süre : " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Yanlış hatırlamıyorsam aşağıdaki komut belli bir satırdan (65536) sonra sorun çıkarıyordu.

Application.Transpose
 
=Nlist dediğimde kabul ettiremedim. Sürekli hata verdi.
Application.Transpose bunu da bilmiyordum.
 
Transpose yapısından kurtulmak için aşağıdaki eklemeyi yapmak gerekir.

ReDim NList(1 To UBound(AraList, 1) , 1 To 1)

Döngü içindeki dizi satırını da aşağıdaki gibi yazmalısınız.

NList(x, 1) = KodList(k, 3)
 
Alternatif olarak işlem ADO ile yapılabilir.

C++: 
Option Explicit

Sub Fast_Vlookup()
    Dim S1 As Worksheet, S2 As Worksheet, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
    
    Process_Time = Timer
    
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    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"""

    My_Query = "Select Table_2.[Açıklama] From [" & S2.Name & "$]" & " As Table_1 " & _
               "Left Join [" & S1.Name & "$] As Table_2 " & _
               "On Table_1.[Kod No] = Table_2.[Kod No] And Table_1.[Kod] = Table_2.[Kod]"
        
    Set My_Recordset = My_Connection.Execute(My_Query)
  
    With S2
        .Range("N2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
   
    If My_Connection.State <> 0 Then My_Connection.Close

    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif olarak işlem ADO ile yapılabilir.

C++: 
Option Explicit

Sub Fast_Vlookup()
    Dim S1 As Worksheet, S2 As Worksheet, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
   
    Process_Time = Timer
   
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    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"""

    My_Query = "Select Table_2.[Açıklama] From [" & S2.Name & "$]" & " As Table_1 " & _
               "Left Join [" & S1.Name & "$] As Table_2 " & _
               "On Table_1.[Kod No] = Table_2.[Kod No] And Table_1.[Kod] = Table_2.[Kod]"
       
    Set My_Recordset = My_Connection.Execute(My_Query)
 
    With S2
        .Range("N2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
  
    If My_Connection.State <> 0 Then My_Connection.Close

    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub
Genişletmek için tıkla ...

Set My_Recordset = My_Connection.Execute(My_Query)

Bu satırda hata alıyor. Korhan Bey. Başlık isimleri, sayfa isimlerinde değişiklikler yaptım.
 
Uyarlama yaparken hata yapmış olabilirsiniz.
 
F ve G sütunlarını ayrı bir sütunda birleştirerek tek sütun haline getirilip düşeyara yapılabilir.

=F1&";"&G1 gibi bir ayraçla yapılırsa, 10-1 ve 1-01 gibi ikililerin aynı sonucu verme riskleri ortadan kalkmış olur.
 
Alternatif.

Kod: 
Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim a(), dc As Object
    Z = TimeValue(Now)
    Set s1 = Sheets("Kodlar")
    Set s2 = Sheets("Data")
    Set dc = CreateObject("SCRiPTiNG.DiCTiONARY")
        son = s1.Cells(Rows.Count, 1).End(3).Row
        a = s1.Range("A1:C" & son).Value
            For i = 2 To UBound(a)
                dc(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
            Next i
        son = 0
        son = s2.Cells(Rows.Count, 6).End(3).Row
        a = s2.Range("F1:G" & son).Value
        ReDim b(1 To UBound(a), 1 To 1)
            For i = 2 To UBound(a)
            say = say + 1
                If dc.exists(a(i, 1) & "|" & a(i, 2)) Then
                    b(say, 1) = dc(a(i, 1) & "|" & a(i, 2))
                End If
            Next i
        Application.ScreenUpdating = False
        s2.[M2].Resize(say) = b
        Application.ScreenUpdating = True
    MsgBox CDate(TimeValue(Now) - Z), vbInformation, "İşlem Sürneiz"
End Sub
 
@ÖmerFaruk @Korhan Ayhan @Ziynettin değerli uzmanlar,
Data Sayfasındaki M sutundaki verileri yeni bir tuşa atayarak aynı olan aşı bilgilerini "A-M" sütunundaki başlıklar ve değerler ile bilgilerini yeni kitap halinde "Biontech5, Biontech6"gibi klasörün içerisine filtreleme imkanımız olur mu? İnşallah tarif edebilmişimdir.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst