İki Koşullu Veri Aktarma

MrExcelMr · 6 Eylül 2021

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ı,

Kodlar Sayfası,

Sağlıklı günler dileriz.

ÖmerFaruk · 6 Eylül 2021

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)

MrExcelMr · 7 Eylül 2021

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

ÖmerFaruk · 7 Eylül 2021

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

MrExcelMr · 7 Eylül 2021

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

ÖmerFaruk · 7 Eylül 2021

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

ÖmerFaruk · 7 Eylül 2021

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

Korhan Ayhan · 7 Eylül 2021

Yanlış hatırlamıyorsam aşağıdaki komut belli bir satırdan (65536) sonra sorun çıkarıyordu.

Application.Transpose

gicimi · 7 Eylül 2021

Korhan Ayhan' Alıntı:
Yanlış hatırlamıyorsam aşağıdaki komut belli bir satırdan (65536) sonra sorun çıkarıyordu.

Application.Transpose

@Korhan Ayhan Bey örnekteki kodu 100.000 üzeri satırda sorun çıkarmaması için koddaki değişiklikler ne olmalı.

ÖmerFaruk · 7 Eylül 2021

=Nlist dediğimde kabul ettiremedim. Sürekli hata verdi.
Application.Transpose bunu da bilmiyordum.

Korhan Ayhan · 7 Eylül 2021

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)

ÖmerFaruk · 7 Eylül 2021

Çok teşekkürler @Korhan Ayhan

Korhan Ayhan · 7 Eylül 2021

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

gicimi · 7 Eylül 2021

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

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.

Korhan Ayhan · 7 Eylül 2021

Uyarlama yaparken hata yapmış olabilirsiniz.

ahmetinal.95 · 7 Eylül 2021

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.

Ziynettin · 7 Eylül 2021

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

MrExcelMr · 8 Eylül 2021

@ÖmerFaruk @Korhan Ayhan @Ziynettin Beyler çok teşekkür ederiz. Emeğine sağlık.

@ÖmerFaruk Bey Korhan beyin vermiş olduğu bilgilere göre koddun revize halini paylaşma şansınız olur mu.

MrExcelMr · 8 Eylül 2021

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

gicimi · 9 Eylül 2021

Korhan Ayhan' Alıntı:
Uyarlama yaparken hata yapmış olabilirsiniz.

Evet Hocam ")" eklememişim.

İki Koşullu Veri Aktarma

MrExcelMr

ÖmerFaruk

Destek Ekibi

MrExcelMr

ÖmerFaruk

Destek Ekibi

MrExcelMr

ÖmerFaruk

Destek Ekibi

ÖmerFaruk

Destek Ekibi

Korhan Ayhan

Administrator

gicimi

ÖmerFaruk

Destek Ekibi

Korhan Ayhan

Administrator

ÖmerFaruk

Destek Ekibi

Korhan Ayhan

Administrator

gicimi

Korhan Ayhan

Administrator

ahmetinal.95

Ziynettin

Destek Ekibi

MrExcelMr

MrExcelMr

gicimi