• DİKKAT

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

Düşeyara bir sonrakini bul

N

nadirornek

Katılım
14 Haziran 2006
Mesajlar
575
Sayfa1'in A sutununda bulunan isme karşılık gelen veriyi Sayfa2'nin B sutunundan alıyor.
Ancak Sayfa1'in A sutununda aynı isimden birden fazla olduğu için Sayfa2'nin B sutununda
isme karşılık gelen ilk veriyi buluyor diğer benzer olan ismin karşılığına yazıyor.Buda karşılaştırmada hata oluşturuyor.Bir döngüye ihtiyacım var.
 

Ekli dosyalar

nadirornek' Alıntı:
Sayfa1'in A sutununda bulunan isme karşılık gelen veriyi Sayfa2'nin B sutunundan alıyor.
Ancak Sayfa1'in A sutununda aynı isimden birden fazla olduğu için Sayfa2'nin B sutununda
isme karşılık gelen ilk veriyi buluyor diğer benzer olan ismin karşılığına yazıyor.Buda karşılaştırmada hata oluşturuyor.Bir döngüye ihtiyacım var.
Genişletmek için tıkla ...

Kullandığınız kodu aşağıda ki ile değiştirerek deneyiniz:
Kod: 
Private Sub CommandButton1_Click()
    Dim sh1, sh2 As Worksheet, k As Range, sat As Byte, alan As Range
    Dim ss1, ss2 As Integer, aranan As Range
    
    Set sh1 = Sheets("Sayfa1")
    Set sh2 = Sheets("Sayfa2")
    ss1 = sh1.Range("A" & Rows.Count).End(3).Row
    ss2 = sh2.Range("A" & Rows.Count).End(3).Row
    Set alan = sh2.Range("A1:A" & ss2)
    sat = 2
    Set aranan = sh1.Range("A" & sat)
            Set k = alan.Find(aranan.Value, , xlValues, xlWhole)
            If Not k Is Nothing Then
                adr = k.Address
                    sh1.Cells(aranan.Row, 2).Value = sh2.Cells(k.Row, 2).Value
        For a = aranan.Row + 1 To ss1
            If sh1.Cells(a, 1).Value = aranan.Value Then

                    Set k = alan.FindNext(k)
                        sh1.Cells(a, 2).Value = sh2.Cells(k.Row, 2).Value
            End If
        Next a
            End If
End Sub
 

Ekli dosyalar

Son düzenleme:
nadirornek' Alıntı:
Kodu çalıştırdığımda hiçbir işlem yapmıyor.
Genişletmek için tıkla ...
Önceki mesajıma örnek dosya ekledim.
Çalışmamasının sebebi, arama kriterinde tam eşleşme istenmesi dir. Dikkat ederseniz, siz "AA " ve "AA" şeklinde (boşluk bırakarak ve bırakmayarak) iki farklı şekilde yazmışsınız. Bunu düzeltirseniz sizin dosyanızda da çalışacaktır.
 
Arama kriterlerinin içerisinde boşluklu bulda var.Her hücre boşluksuz değildir veriden sonra boşluklu hücrelerde mevcuttur.
 
nadirornek' Alıntı:
Arama kriterlerinin içerisinde boşluklu bulda var.Her hücre boşluksuz değildir veriden sonra boşluklu hücrelerde mevcuttur.
Genişletmek için tıkla ...

Boşluk yada başka karakter olsa bile aramada olumlu sonuç versin diyorsanız,
Kod: 
 Set aranan = sh1.Range("A" & sat)
            Set k = alan.Find(aranan.Value, , xlValues, [B][COLOR="Red"]xlWhole[/COLOR][/B])
Şeklinde ki kod satırında kırmızı olarak işaretlediğimi xlPart olarak değiştiriniz.
 
Private Sub CommandButton1_Click()
Dim sh1, sh2 As Worksheet, k As Range, sat As Byte, alan As Range
Dim ss1, ss2 As Integer, aranan As Range

Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
ss1 = sh1.Range("A" & Rows.Count).End(3).Row
ss2 = sh2.Range("A" & Rows.Count).End(3).Row
Set alan = sh2.Range("A1:A" & ss2)
sat = 2
Set aranan = sh1.Range("A" & sat)
Set k = alan.Find(aranan.Value, , xlValues, xlPart)
If Not k Is Nothing Then
adr = k.Address
sh1.Cells(aranan.Row, 2).Value = sh2.Cells(k.Row, 2).Value
For a = aranan.Row + 1 To ss1
If sh1.Cells(a, 1).Value = aranan.Value Then

Set k = alan.FindNext(k)
sh1.Cells(a, 2).Value = sh2.Cells(k.Row, 2).Value
End If
Next a
End If
End Sub

Kod güzel çalışıyor.Ama eksik çalışıyor.Sayfa1'de A2 hücresi ne ise onu buluyor.Diğer verileri bulmuyor.
 
Kod: 
Private Sub CommandButton1_Click()
    Dim sh1, sh2 As Worksheet, k As Range, sat As Byte, alan As Range
    Dim ss1, ss2 As Integer, aranan As Range, eskiler As Range, bak As Range
    Set sh1 = Sheets("Sayfa1")
    Set sh2 = Sheets("Sayfa2")
    ss1 = sh1.Range("A" & Rows.Count).End(3).Row
    ss2 = sh2.Range("A" & Rows.Count).End(3).Row
    Set alan = sh2.Range("A1:A" & ss2)
    sh1.Range("B2:B" & ss2).ClearContents
For sat = 2 To ss1
Set eskiler = sh1.Range("A1:A" & sat - 1)
    Set aranan = sh1.Range("A" & sat)
Set bak = eskiler.Find(aranan, , xlValues, xlWhole)
If Not bak Is Nothing Then GoTo devam
            Set k = alan.Find(aranan.Value, , xlValues, xlPart)
            If Not k Is Nothing Then
                adr = k.Address
                    sh1.Cells(aranan.Row, 2).Value = sh2.Cells(k.Row, 2).Value
        For a = aranan.Row + 1 To ss1
            If sh1.Cells(a, 1).Value = aranan.Value Then
                    Set k = alan.FindNext(k)
                        sh1.Cells(a, 2).Value = sh2.Cells(k.Row, 2).Value
            End If
        Next a
            End If
devam:
Next sat
End Sub
 
sh1.Range("B2:B" & ss2).ClearContents
bu sil kodu olmayaçak

For sat = 2 To ss1
kod satırında takılıyor.
Döngü A sutunu için bütün hücrelere olacak
 
Hata veren yeri buldum galiba A sutunu 255.satıra kadar buluyor.Sonrasında döngü dönmüyor neden açaba.
 
Dim sh1, sh2 As Worksheet, k As Range, sat As Byte, alan As Range
Kodtaki bu ilk satırı
Dim sh1, sh2 As Worksheet, k As Range, sat As Integer, alan As Range
bu satırla değişince sorunu çözmüş oldum.

As Byte yerine As Integer yazınca sorun çözüldü.

Döngü tıkanıyordu bu şekilde giderdim.Sizlerinde yoğun ilginize teşekkür ederim.
 
Private Sub CommandButton1_Click()
Dim sh1, sh2 As Worksheet, k As Range, sat As Integer, alan As Range
Dim ss1, ss2 As Integer, aranan As Range, eskiler As Range, bak As Range
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
ss1 = sh1.Range("A" & Rows.Count).End(3).Row
ss2 = sh2.Range("A" & Rows.Count).End(3).Row
Set alan = sh2.Range("A1:A" & ss2)
sh1.Range("B2:B" & ss2).ClearContents
For sat = 2 To ss1
Set eskiler = sh1.Range("A1:A" & sat - 1)
Set aranan = sh1.Range("A" & sat)
Set bak = eskiler.Find(aranan, , xlValues, xlWhole)
If Not bak Is Nothing Then GoTo devam
Set k = alan.Find(aranan.Value, , xlValues, xlPart)
If Not k Is Nothing Then
adr = k.Address
sh1.Cells(aranan.Row, 2).Value = sh2.Cells(k.Row, 2).Value
For a = aranan.Row + 1 To ss1
If sh1.Cells(a, 1).Value = aranan.Value Then
Set k = alan.FindNext(k)
sh1.Cells(a, 2).Value = sh2.Cells(k.Row, 2).Value
End If
Next a
End If
devam:
Next sat
End Sub

A ve B sütunundaki veriler fazlalaştıkça 5000-10000 satır olunca çok yavaş çalışıyor buda zaman alıyor.Kodun hızlı çalışmasını sağlayabilirmiyiz.
 
Kodun daha hızlı çalışması için yardımcı sütun kullanmanın sakıncası var mı?
 
Aşağıdaki kodu deneyiniz.

10.000 satırlık veride 30 saniyede işlemi tamamladı. (İ7 işlemci)

Veri sayısı artarsa yavaşlama yaşayabilirsiniz.

Kod: 
Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S1.Range("A:A").Insert Shift:=xlToRight
    Son = S1.Cells(Rows.Count, 2).End(3).Row
    
    With S1.Range("A2:A" & Son)
        .Formula = "=TRIM(B2)&COUNTIF(B$1:B2,B2)"
        .Value = .Value
    End With
    
    
    S2.Range("A:A").Insert Shift:=xlToRight
    Son = S2.Cells(Rows.Count, 2).End(3).Row
    
    With S2.Range("A2:A" & Son)
        .Formula = "=TRIM(B2)&COUNTIF(B$1:B2,B2)"
        .Value = .Value
    End With
    
    On Error Resume Next
    
    With S1.Range("C2:C" & Son)
        .Formula = "=IFERROR(VLOOKUP(A2," & S2.Name & "!A:C,3,0),"""")"
        .Value = .Value
    End With
    
    S1.Range("A:A").Delete
    S2.Range("A:A").Delete
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst