• DİKKAT

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

Ayrı Sayfada Veri Bulma

gicimi

gicimi

Altın Üye
Katılım
3 Şubat 2008
Mesajlar
593
Excel Vers. ve Dili
Office 2016 Eng. 64 Bit
Merhabalar.

Sayfa1 A sütunundaki bilgiler "Anaveri" Sayfa2 A sutununda ki bilgiler ile aynıysa eğer Sayfa1 deki B C D E F sutündaki bilgileri Sayfa2 B C D E F yazsın arama yapacak A sütunundaki bilgiler 30500 adettir.

Yardımlarınızı bekliyorum.
 
Verilerinizi azaltıp örnek dosyanızı ekleyiniz.:cool:
 
Aşağıdaki kodu deneyiniz.

Kod: 
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("Sayfa1").Range("A1").CurrentRegion.Resize(, 6).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 2) & "#" & Dizi(X, 3) & "#" & Dizi(X, 4) & "#" & Dizi(X, 5) & "#" & Dizi(X, 6)
        Next
        
        Dizi = Sheets("Sayfa2").Range("A1").CurrentRegion.Resize(, 6).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 2) = Split(.Item(Dizi(X, 1)), "#")(0)
                Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(1)
                Dizi(X, 4) = Split(.Item(Dizi(X, 1)), "#")(2)
                Dizi(X, 5) = Split(.Item(Dizi(X, 1)), "#")(3)
                Dizi(X, 6) = Split(.Item(Dizi(X, 1)), "#")(4)
            Else
                Dizi(X, 2) = ""
                Dizi(X, 3) = ""
                Dizi(X, 4) = ""
                Dizi(X, 5) = ""
                Dizi(X, 6) = ""
            End If
        Next
    End With
    
    Sheets("Sayfa2").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("Sayfa2").Range("A1").CurrentRegion.Resize(, 6) = Dizi
    Sheets("Sayfa2").Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Selam Korhan Bey,öncelikle iyi bayramlar diliyorum,soruyu soran arkadaşın müsadesi ile benimde böyle bir sorum olacaktı kodlarınızı aldım kendi çalışmama uyarladım sorunsuz çalışyor fakat şöyle yani benim dosyama göre 2 sorum olacak,birinci sorum sayfa 1 deki verilerde metin biçiminde olursa veriyi bulmuyor ama veri üzerine tıklayıp,sayısa dönüşyür diyince veriyi buluyor bunun çözümü için kodlarda ne yapmalıyım, ikinci sorum,örnek veri:sayfa 1 de ,123ct1234678, iken sayfa 2 de ,örnek : 12345678 ise de eşleşmesini bulmasını istiyorum,ne yapmalıyım kolay gelsin teşekkürler..
 
Günaydın arkadaşlar yardımcı olabilirmisiniz? kolay gelsin..
 
Zahmet olmazsa örnek dosya ekleyebilir misiniz?
 
ADER_34' Alıntı:
Selam dosya ekte yardımcı olursanız sevinirim kolay gelsin teşekkürler..
Genişletmek için tıkla ...

Aşağıdaki kodları sizdeki ile değiştirip denermisiniz.Kırmızı yerler sütunları belirtiyor.
Kod: 
Option Explicit

Sub Fast_Vlookup()
    Dim Zaman As Double, Dizi As Variant, X As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    Sayfa1.Select
    Range("L2").Select
    Selection.Copy
  Sayfa1.Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Range("L8").Select
    Dizi = Sheets("Sayfa1").Range("A1").CurrentRegion.Resize(, [COLOR="Red"][B]7[/B][/COLOR]).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 2) & "#" & Dizi(X, 3) & "#" & Dizi(X, 4) & "#" & Dizi(X, 5) & "#" & Dizi(X, 6) [COLOR="Red"][B]& "#" & Dizi(X, 7)[/B][/COLOR]
        Next
        
        Dizi = Sheets("Sayfa2").Range("A1").CurrentRegion.Resize(, [COLOR="Red"][B]7[/B][/COLOR]).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 2) = Split(.Item(Dizi(X, 1)), "#")(0)
                Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(1)
                Dizi(X, 4) = Split(.Item(Dizi(X, 1)), "#")(2)
                Dizi(X, 5) = Split(.Item(Dizi(X, 1)), "#")(3)
                Dizi(X, 6) = Split(.Item(Dizi(X, 1)), "#")(4)
               [COLOR="red"][B] Dizi(X, 7) = Split(.Item(Dizi(X, 1)), "#")(5)[/B][/COLOR]
            Else
                Dizi(X, 2) = ""
                Dizi(X, 3) = ""
                Dizi(X, 4) = ""
                Dizi(X, 5) = ""
                Dizi(X, 6) = ""
               [COLOR="red"][B] Dizi(X, 7) = ""[/B][/COLOR]
            End If
        Next
    End With
    
    Sheets("Sayfa2").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("Sayfa2").Range("A1").CurrentRegion.Resize(,[COLOR="red"][B] 7[/B][/COLOR]) = Dizi
    Sheets("Sayfa2").Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Selam sayın vardar07, kodları denedim sorunsuz,1 inci sorum çözüm buldu, çok teşekkür ederim şimdi 2 inci sorum,çözüm bulamadım,ikinci sorum,örnek veri:sayfa 1 de ,123ct1234678, iken sayfa 2 de ,örnek : 12345678 ise de eşleşmesini bulmasını istiyorum,ne yapmalıyım kolay gelsin teşekkürler..
 
Aşağıdaki linkte istediğinize yakın bir konu işlenmişti. İnceleyiniz.

Link
 
Günaydın Korhan Bey sanırım bu kodlar tek sayfa üzerinde işlem yapıyor,benim işlemim 2 sayfa üzerinde ve düşeyara şeklinde olacak,bu kodlar işimi görmedi yardımcı olurmusunuz? kolay gelsin..
 
Düşeyara fonksiyonu ile istediğiniz tarzda eşleştirme yapılamaz. Veriler tek tek vermiş olduğum linkteki gibi sorgulanarak eşleşme kontrolü yapılabilir.
 
Anladım Korhan Bey,peki şu kodu sizin kodlarınıza birleştirebilirmiyiz? tabi sayfa1 ve sayfa2 "A"sütunu şeklinde böyle buna benzer bir kod..
Sub Temizle()
Application.ScreenUpdating = False
Dim i&, h&
For i = 2 To 5000
If Cells(i, 1) <> Empty Then
If IsNumeric(Cells(i, 1)) = True Then
Cells(i, "a") = Cells(i, 1)
ElseIf InStr(1, Cells(i, 1), "*", vbTextCompare) > 0 Then
Cells(i, "a") = Replace(Cells(i, 1), "*", "")

Else
For h = 1 To Len(Cells(i, 1))
If IsNumeric(Right(Cells(i, 1), h)) = False Then
Cells(i, "a") = Right(Cells(i, 1), h - 1)
Exit For
End If
Next h
End If
End If
Next i

i = Empty: h = Empty
Application.ScreenUpdating = True
kolay gelsin..
 
Deneyin.

Kod: 
Option Explicit

Sub Fast_Vlookup()
    Dim Zaman As Double, Dizi As Variant, X As Long, Son As Long, Y As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    With Sheets("Sayfa1")
        .Select
        Son = .Cells(.Rows.Count, 1).End(3).Row
        
        For X = 2 To Son
            If .Cells(X, 1) <> Empty Then
                If IsNumeric(.Cells(X, 1)) = True Then
                    .Cells(X, 1) = .Cells(X, 1)
                ElseIf InStr(1, .Cells(X, 1), "*", vbTextCompare) > 0 Then
                    .Cells(X, 1) = Replace(.Cells(X, 1), "*", "")
                Else
                    For Y = 1 To Len(.Cells(X, 1))
                        If IsNumeric(Right(.Cells(X, 1), Y)) = False Then
                            .Cells(X, 1) = Right(.Cells(X, 1), Y - 1)
                            Exit For
                        End If
                    Next
                End If
            End If
        Next
        
        .Range("L2") = 1
        .Range("L2").Copy
        .Range("A2:A" & Son).PasteSpecial , Operation:=xlMultiply
        .Range("A1").Select
        Dizi = .Range("A1").CurrentRegion.Resize(, 7).Value
    End With
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 2) & "#" & Dizi(X, 3) & "#" & Dizi(X, 4) & "#" & Dizi(X, 5) & "#" & Dizi(X, 6) & "#" & Dizi(X, 7)
        Next
        
        With Sheets("Sayfa2")
            Son = .Cells(.Rows.Count, 1).End(3).Row
            For X = 2 To Son
                If .Cells(X, 1) <> Empty Then
                    If IsNumeric(.Cells(X, 1)) = True Then
                        .Cells(X, 1) = .Cells(X, 1)
                    ElseIf InStr(1, .Cells(X, 1), "*", vbTextCompare) > 0 Then
                        .Cells(X, 1) = Replace(.Cells(X, 1), "*", "")
                    Else
                        For Y = 1 To Len(.Cells(X, 1))
                            If IsNumeric(Right(.Cells(X, 1), Y)) = False Then
                                .Cells(X, 1) = Right(.Cells(X, 1), Y - 1)
                                Exit For
                            End If
                        Next
                    End If
                End If
            Next
            
            Dizi = .Range("A1").CurrentRegion.Resize(, 7).Value
        End With
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 2) = Split(.Item(Dizi(X, 1)), "#")(0)
                Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(1)
                Dizi(X, 4) = Split(.Item(Dizi(X, 1)), "#")(2)
                Dizi(X, 5) = Split(.Item(Dizi(X, 1)), "#")(3)
                Dizi(X, 6) = Split(.Item(Dizi(X, 1)), "#")(4)
                Dizi(X, 7) = Split(.Item(Dizi(X, 1)), "#")(5)
            Else
                Dizi(X, 2) = ""
                Dizi(X, 3) = ""
                Dizi(X, 4) = ""
                Dizi(X, 5) = ""
                Dizi(X, 6) = ""
                Dizi(X, 7) = ""
            End If
        Next
    End With
    
    With Sheets("Sayfa2")
        .Range("A1").CurrentRegion.Resize(, 7) = Dizi
        .Cells.EntireColumn.AutoFit
        .Select
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Günaydın Korhan Bey,Kodlarınızı denedim sadece sayfa 2 A sütununda satırları sayıya dönüştürmüyor kolay gelsin..
 
Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.
 
Korhan Bey, kodalrınızı takip ettim şu kod dizesinin altında:
kısa örnek kısım : With Sheets("Sayfa2") eksik olan .Range("L2") = 1
.Range("L2").Copy
.Range("A2:A" & Son).PasteSpecial , Operation:=xlMultiply dizesini ekledim denedim çalıştı sorun çözüldü çok teşekkür ederim kolay gelsin teşekkürler..
 
gicimi' Alıntı:
Merhabalar.

Sayfa1 A sütunundaki bilgiler "Anaveri" Sayfa2 A sutununda ki bilgiler ile aynıysa eğer Sayfa1 deki B C D E F sutündaki bilgileri Sayfa2 B C D E F yazsın arama yapacak A sütunundaki bilgiler 30500 adettir.

Yardımlarınızı bekliyorum.

Formül olarak yardımcı olabilir misiniz?
Genişletmek için tıkla ...
 
gicimi' Alıntı:
gicimi' Alıntı:
Merhabalar.

Sayfa1 A sütunundaki bilgiler "Anaveri" Sayfa2 A sutununda ki bilgiler ile aynıysa eğer Sayfa1 deki B C D E F sutündaki bilgileri Sayfa2 B C D E F yazsın arama yapacak A sütunundaki bilgiler 30500 adettir.
Genişletmek için tıkla ...
Merhaba.
Her iki sayfada 1'inci satırların BAŞLIK satırı olduğu varsayılmıştır.

-- Formül kullanmak isterseniz aşağıdaki formülü Sayfa2 B2 hücresine uygulayan ve F sütuna kadar sağa doğru, Sayfa2'de A sütunundaki son dolu satıra kadar aşağı doğru kopyalayın.
Kod: 
=EĞER($A2="";"";EĞERHATA(EĞER(VE(EĞERSAY(Sayfa1!$A:$A;$A2)>0;İNDİS(Sayfa1!$A:$F;KAÇINCI($A2;Sayfa1!$A:$A;0);SÜTUNSAY($A2:A2)+1)<>"");İNDİS(Sayfa1!$A:$F;KAÇINCI($A2;Sayfa1!$A:$A;0);SÜTUNSAY($A2:A2)+1);"");""))
-- Kod kullanmak isterseniz, aşağıdaki kod'u Sayfa1'in kod bölümüne uygulayınız ve ir düğmeye atayarak çalıştırın.
Kod: 
Sub BARAN()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")

son2 = [A65536].End(3).Row
For a = 2 To son2
    If WorksheetFunction.CountIf(s1.Range("A:A"), s2.Cells(a, 1)) = 0 Then GoTo 10
       b = WorksheetFunction.Match(s2.Cells(a, 1), s1.Range("A:A"), 0)
          s2.Cells(a, 2) = s1.Cells(b, 2)
          s2.Cells(a, 3) = s1.Cells(b, 3)
          s2.Cells(a, 4) = s1.Cells(b, 4)
          s2.Cells(a, 5) = s1.Cells(b, 5)
          s2.Cells(a, 6) = s1.Cells(b, 6)
10
Next

End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst