• DİKKAT

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

Eşleşen Verileri Çek

B

baydeniro

Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Merhaba Arkadaşlar,
DATA ve RAPOR adında 2 sayfamız var. RAPOR sayfası A sütunundaki veriler DATA sayfası A sütununda bulunuyorsa B-C-D sütunundaki verileri RAPOR sayfasına getirmek mümkün müdür.
225214
 

Ekli dosyalar

Deneyiniz.

İki alternatif;

C++: 
Option Explicit

Sub Fast_Vlookup_Ado_Yontemi()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDB.Connection")
    Set Kayit_Seti = CreateObject("AdoDB.Recordset")
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
   
    Sorgu = "Select Data.[Fiyat],Data.[Miktar],Data.[Tutar] From [RAPOR$] As Rapor " & _
            "Left Join [DATA$] As Data On Rapor.[Ürün] = Data.[Ürün]"

    Kayit_Seti.Open Sorgu, Baglanti, 1, 1

    With Sheets("RAPOR")
        .Range("B2:D" & .Rows.Count).ClearContents
        If Kayit_Seti.RecordCount > 0 Then
            .Range("B2").CopyFromRecordset Kayit_Seti
            If .Cells(.Rows.Count, 1).End(3).Row > 1 Then
                On Error Resume Next
                .Range("B2:D" & .Cells(.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeBlanks) = 0
                On Error GoTo 0
            End If
            
            MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
        Else
            MsgBox "Uygun veri bulunamadı!" & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
        End If
    End With

    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
End Sub


C++: 
Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim X As Long, Son As Long, Kriter As Variant, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("RAPOR")
   
    S2.Range("B2:D" & S2.Rows.Count).ClearContents
   
    With CreateObject("Scripting.Dictionary")
        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
        If Son < 3 Then Son = 3
        Veri = S1.Range("A2:D" & Son).Value
       
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            .Item(Veri(X, 1)) = Array(Veri(X, 2), Veri(X, 3), Veri(X, 4))
        Next
       
        
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        If Son < 3 Then Son = 3
        Veri = S2.Range("A2:D" & Son).Value
       
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If .Exists(Veri(X, 1)) Then
                Kriter = .Item(Veri(X, 1))
                Veri(X, 2) = .Item(Veri(X, 1))(0)
                Veri(X, 3) = .Item(Veri(X, 1))(1)
                Veri(X, 4) = .Item(Veri(X, 1))(2)
            Else
                Veri(X, 2) = 0
                Veri(X, 3) = 0
                Veri(X, 4) = 0
            End If
        Next
   
        S2.Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    End With
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

İki alternatif;

C++: 
Option Explicit

Sub Fast_Vlookup_Ado_Yontemi()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Zaman As Double
   
    Zaman = Timer
   
    Set Baglanti = CreateObject("AdoDB.Connection")
    Set Kayit_Seti = CreateObject("AdoDB.Recordset")
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
  
    Sorgu = "Select Data.[Fiyat],Data.[Miktar],Data.[Tutar] From [RAPOR$] As Rapor " & _
            "Left Join [DATA$] As Data On Rapor.[Ürün] = Data.[Ürün]"

    Kayit_Seti.Open Sorgu, Baglanti, 1, 1

    With Sheets("RAPOR")
        .Range("B2:D" & .Rows.Count).ClearContents
        If Kayit_Seti.RecordCount > 0 Then
            .Range("B2").CopyFromRecordset Kayit_Seti
            If .Cells(.Rows.Count, 1).End(3).Row > 1 Then
                On Error Resume Next
                .Range("B2:D" & .Cells(.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeBlanks) = 0
                On Error GoTo 0
            End If
           
            MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
        Else
            MsgBox "Uygun veri bulunamadı!" & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
        End If
    End With

    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
End Sub


C++: 
Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim X As Long, Son As Long, Kriter As Variant, Zaman As Double
  
    Zaman = Timer
  
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("RAPOR")
  
    S2.Range("B2:D" & S2.Rows.Count).ClearContents
  
    With CreateObject("Scripting.Dictionary")
        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
        If Son < 3 Then Son = 3
        Veri = S1.Range("A2:D" & Son).Value
      
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            .Item(Veri(X, 1)) = Array(Veri(X, 2), Veri(X, 3), Veri(X, 4))
        Next
      
       
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        If Son < 3 Then Son = 3
        Veri = S2.Range("A2:D" & Son).Value
      
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If .Exists(Veri(X, 1)) Then
                Kriter = .Item(Veri(X, 1))
                Veri(X, 2) = .Item(Veri(X, 1))(0)
                Veri(X, 3) = .Item(Veri(X, 1))(1)
                Veri(X, 4) = .Item(Veri(X, 1))(2)
            Else
                Veri(X, 2) = 0
                Veri(X, 3) = 0
                Veri(X, 4) = 0
            End If
        Next
  
        S2.Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    End With
      
    Set S1 = Nothing
    Set S2 = Nothing
      
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Korhan Ayhan üstadım çok çok teşekkür, elinize emeğinize sağlık. Harika 2 kod. Umarım forumdaki arkadaşlar da bu harika kodlardan faydalanırlar. Müthiş başarılı çalıştılar. Sağlıcakla kalın
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst