• DİKKAT

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

Aynı sayfadaki 2 sütunlu 2 tabloyu karşılaştırma

  • Konbuyu başlatan Konbuyu başlatan bybyby
  • Başlangıç tarihi Başlangıç tarihi
B

bybyby

Katılım
6 Aralık 2007
Mesajlar
33
Excel Vers. ve Dili
Excel 2007 Türkçe
Merhaba arkadaşlar,

Bir sayfada A B C D sütunlarımız var.

A1 hücresini C sütununun komplesinde tarayacak ve örneğin C8 hücresinde buldu diyelim. D8 hücresine B1 verisini yazacak. Bu şekilde yaklaşık 40bin satır veriye sahip 2 tabloyu eşleştirecek.

Veriyi bulamazsa bir sonraki satıra geçecek.

Bu şekilde bir düzenleme için yardım talep ediyorum. Türkçe yazılım kullanıyorum. Şimdiden teşekkürler.
 
Örnek bir dosya yardım almanızı hızlandırır. Örnek dosyanızı bir dosya paylaşım sitesine yükleyebilirsiniz.
 
Modul içine ekleyip deneyiniz.
Kod: 
Sub bul_aktar()
With Sheets("Sayfa1")
son = .Range("A1048576").End(3).Row
son1 = .Range("C1048576").End(3).Row
For Each veri In .Range("A1:A" & son)
Set bul = .Range("c1:c" & son1).Find(veri, , xlValues, xlWhole)
If Not bul Is Nothing Then
.Cells(veri.Row, 2) = .Cells(bul.Row, 4)
End If
Next
End With
End Sub
 
Hocam emeğinize sağlık. Kusursuz çalışıyor. Çok çok çok teşekkürler. beni büyük bir dertten kurtardınız.
 
Set bul = .Range("c1:c" & son1).Find(veri, , xlValues, xlWhole)

Makronun bu satırında hata alıyorum. Sebebi ne olabilir?
 
Ne gibi hata alıyorsunuz. Ya hata veren dosyayı paylaşın yada hata resmini yayınlarsanız çözmeye çalışırız.
 
40bin satırlık veri karşılaştırması yapıyordum. Veriler cümleler halinde ve satırlar içerisinde rakamlar, metinler, özel karakterler mevcut. Boş satırlar da var. Verilerin karşılaştırma işlemi 20-25 dakika sürüyordu. Aşağıdaki kod ile 1-2 saniyede karşılaştırıp işlem yapabiliyorum. Ancak bu kodda da # değerinden önceki veriyi alıyor sonrasını almıyor. Bu sorunu nasıl çözebilirim?



Option Explicit

Sub Fast_Vlookup()
Dim Zaman As Double, Dizi As Variant, X As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Zaman = Timer

Dizi = Sheets("Turkish").Range("A1").CurrentRegion.Resize(, 4).Value

With CreateObject("Scripting.Dictionary")
For X = 2 To UBound(Dizi, 1)
.Item(Dizi(X, 1)) = Dizi(X, 4) & "#" & Dizi(X, 3) & "#" & Dizi(X, 2)
Next

Dizi = Sheets("English").Range("A1").CurrentRegion.Resize(, 12).Value

For X = 2 To UBound(Dizi, 1)
If .Exists(Dizi(X, 1)) Then
Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(1)
'Else
'Dizi(X, 4) = ""
End If
Next
End With

Sheets("English").Range("A2:A" & Rows.Count).NumberFormat = "@"
Sheets("English").Range("A1").CurrentRegion.Resize(, 12) = Dizi

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Merhaba,
#3. mesajdaki ekli dosyanız için aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
Sub Dusey_ARA()
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long, t As Double
t = TimeValue(Now)
With Sheets("Sayfa1")
Set d = CreateObject("Scripting.Dictionary")
b = Range("C1:D" & .Range("A1048576").End(3).Row)
    For i = 1 To UBound(b)
        d(b(i, 1)) = b(i, 2)
    Next i
On Error Resume Next
a = Range("A1:A" & .Range("C1048576").End(3).Row)
ReDim c(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        Say = Say + 1
        c(Say, 1) = d(a(i, 1))
    Next i
Application.ScreenUpdating = False
.Range("B:B").ClearContents
.[B1].Resize(Say) = c
Application.ScreenUpdating = True
End With
MsgBox "İşlem süreneiz: " & CDate(TimeValue(Now) - t), vbInformation
End Sub
 
B sütunundaki mevcut verinin üstüne yazdığında eşleşmeyen eski veriyi silmemesi için nasıl bir değişiklik yapılabilir kodda?



Ziynettin' Alıntı:
Merhaba,
#3. mesajdaki ekli dosyanız için aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
Sub Dusey_ARA()
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long, t As Double
t = TimeValue(Now)
With Sheets("Sayfa1")
Set d = CreateObject("Scripting.Dictionary")
b = Range("C1:D" & .Range("A1048576").End(3).Row)
    For i = 1 To UBound(b)
        d(b(i, 1)) = b(i, 2)
    Next i
On Error Resume Next
a = Range("A1:A" & .Range("C1048576").End(3).Row)
ReDim c(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        Say = Say + 1
        c(Say, 1) = d(a(i, 1))
    Next i
Application.ScreenUpdating = False
.Range("B:B").ClearContents
.[B1].Resize(Say) = c
Application.ScreenUpdating = True
End With
MsgBox "İşlem süreneiz: " & CDate(TimeValue(Now) - t), vbInformation
End Sub
Genişletmek için tıkla ...
 
İşlem süresi artabilir, deneyiniz.

Kod: 
Sub Dusey_ARA()
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long, t As Double
t = TimeValue(Now)
With Sheets("Sayfa1")
Set d = CreateObject("Scripting.Dictionary")
b = Range("C1:D" & .Range("[COLOR="Red"]C[/COLOR]1048576").End(3).Row)
    For i = 1 To UBound(b)
        d(b(i, 1)) = b(i, 2)
    Next i
On Error Resume Next
Application.ScreenUpdating = False
a = Range("A1:A" & .Range("[COLOR="red"]A[/COLOR]1048576").End(3).Row)
    For i = 1 To UBound(a)
        If d(a(i, 1)) <> "" Then
            Cells(i, 2) = d(a(i, 1))
        Else
            Cells(i, 2) = a(i, 2)
        End If
    Next i
Application.ScreenUpdating = True
End With
MsgBox "İşlem süreneiz: " & CDate(TimeValue(Now) - t), vbInformation
End Sub
 
Son düzenleme:
Hocam kodda hata var. C sütunundaki veri sayısı kadar işlem yapıyor. C sütununda 25bin veri A sütununda 40bin veri var. 40bin veri içinde 25bin veriyi eşleştirip uygun yerlere yapıştırması lazım.


Ziynettin' Alıntı:
İşlem süresi artabilir, deneyiniz.

Kod: 
Sub Dusey_ARA()
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long, t As Double
t = TimeValue(Now)
With Sheets("Sayfa1")
Set d = CreateObject("Scripting.Dictionary")
b = Range("C1:D" & .Range("A1048576").End(3).Row)
    For i = 1 To UBound(b)
        d(b(i, 1)) = b(i, 2)
    Next i
On Error Resume Next
Application.ScreenUpdating = False
a = Range("A1:A" & .Range("C1048576").End(3).Row)
    For i = 1 To UBound(a)
        If d(a(i, 1)) <> "" Then
            Cells(i, 2) = d(a(i, 1))
        Else
            Cells(i, 2) = a(i, 2)
        End If
    Next i
Application.ScreenUpdating = True
End With
MsgBox "İşlem süreneiz: " & CDate(TimeValue(Now) - t), vbInformation
End Sub
Genişletmek için tıkla ...
 
Kod satırında Kırmızı yazılı yerleri düzeltiniz. (11. mesajdaki)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst