DÜŞEYARA YARDIM..

burhanyildirim11 · 22 Ağustos 2022

merhaba

arkadaşlar

ekte örnek dosya iliştirdim.

düşeyarada tablodizisinde olanları silmek , olmayanları sutunun en başına getirmek istiyorum

vba olarak kodunu paylaşabilirseniz sevinirim .

iyi çalışmalar ..

ofis_burhan.xlsx dosyasını indir - download

ofis_burhan.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s5.dosya.tc

YUSUF44 · 22 Ağustos 2022

Mevcutları silecekseniz neden düşeyara ile karşılıklarını getirmeye çalışıyorsunuz?

Korhan Ayhan · 22 Ağustos 2022

Merhaba,

Verilerinizi yedekleyerek deneyiniz.

C++:

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long
    Dim Say As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 5).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("E2:F" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Veri(X, 2)
            End If
        End If
    Next
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A2:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Dizi.Item(Veri(X, 1))
            End If
        End If
    Next
    
    If Say > 0 Then
        S1.Range("A2:B" & S1.Rows.Count).ClearContents
        S1.Range("A2").Resize(Say, 2) = Liste
    End If

    Dizi.RemoveAll
    Erase Liste
    
    Set S1 = Nothing
    Set Dizi = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

burhanyildirim11 · 22 Ağustos 2022

YUSUF44' Alıntı:
Mevcutları silecekseniz neden düşeyara ile karşılıklarını getirmeye çalışıyorsunuz?

hocam olmayanları görmek istiyorum
görsel açısından aynı sayfada olması güzel oluyor

vba da pek bilgim yok
düşeyara yerine başka bir fonksiyon vs varsa bilmiyorum.

sonuç aynı olduktan sonra
her türlü öneriye açığım

burhanyildirim11 · 22 Ağustos 2022

Korhan Ayhan' Alıntı:

Merhaba,

Verilerinizi yedekleyerek deneyiniz.

C++:

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long
    Dim Say As Long, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Sayfa1")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    Son = S1.Cells(S1.Rows.Count, 5).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("E2:F" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Veri(X, 2)
            End If
        End If
    Next
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("A2:A" & Son).Value
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Dizi.Item(Veri(X, 1))
            End If
        End If
    Next
   
    If Say > 0 Then
        S1.Range("A2:B" & S1.Rows.Count).ClearContents
        S1.Range("A2").Resize(Say, 2) = Liste
    End If

    Dizi.RemoveAll
    Erase Liste
   
    Set S1 = Nothing
    Set Dizi = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

hocam ellerinize sağlık
mobildeyim akşam deneyim

ellerinize sağlık teşekkür ederim

YUSUF44 · 22 Ağustos 2022

Yani kısacası A sütunundaki veri E sütununda da varsa A ve B silinsin mi istiyorsunuz?

burhanyildirim11 · 22 Ağustos 2022

YUSUF44' Alıntı:
Yani kısacası A sütunundaki veri E sütununda da varsa A ve B silinsin mi istiyorsunuz?

hocam A sutununa E sutunundaki eşleşen verileri çekeceğiz akabine E sutununda eşleşen verileri sileceğiz.
E sutununda eşleşmeyen veriler kalacak

Korhan Ayhan · 22 Ağustos 2022

Benim ilk önerdiğim kod E sütununda olmayan A sütunundaki verileri siliyor.

Son mesajınıza göre verilerinizi yedekleyerek aşağıdaki kodu deneyiniz.

C++:

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, Dizi_A As Object, Dizi_B As Object
    Dim Veri_E As Variant, Veri_A As Variant, X As Long
    Dim Say_1 As Long, Say_2 As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi_A = VBA.CreateObject("Scripting.Dictionary")
    Set Dizi_B = VBA.CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 5).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri_E = S1.Range("E2:F" & Son).Value
    
    For X = LBound(Veri_E, 1) To UBound(Veri_E, 1)
        If Veri_E(X, 1) <> "" Then
            If Not Dizi_A.Exists(Veri_E(X, 1)) Then
                Dizi_A.Add Veri_E(X, 1), Veri_E(X, 2)
            End If
        End If
    Next
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri_A = S1.Range("A2:B" & Son).Value
    
    ReDim Liste_1(1 To UBound(Veri_A, 1), 1 To 1)
    
    For X = LBound(Veri_A, 1) To UBound(Veri_A, 1)
        Say_1 = Say_1 + 1
        If Veri_A(X, 1) <> "" Then
            If Dizi_A.Exists(Veri_A(X, 1)) Then
                Liste_1(Say_1, 1) = Dizi_A.Item(Veri_A(X, 1))
            End If
            Dizi_B.Item(Veri_A(X, 1)) = 1
        End If
    Next
    
    ReDim Liste_2(1 To UBound(Veri_E, 1), 1 To 2)
    
    For X = LBound(Veri_E, 1) To UBound(Veri_E, 1)
        If Dizi_B.Exists(Veri_E(X, 1)) Then
            Say_2 = Say_2 + 1
            Liste_2(Say_2, 1) = Veri_E(X, 1)
            Liste_2(Say_2, 2) = Dizi_A.Item(Veri_E(X, 1))
        End If
    Next
    
    If Say_1 > 0 Then
        S1.Range("B2:B" & S1.Rows.Count).ClearContents
        S1.Range("B2").Resize(Say_1, 1) = Liste_1
    End If

    If Say_2 > 0 Then
        S1.Range("E2:F" & S1.Rows.Count).ClearContents
        S1.Range("E2").Resize(Say_2, 2) = Liste_2
    End If

    Dizi_A.RemoveAll
    Dizi_B.RemoveAll
    Erase Liste_1
    Erase Liste_2
    
    Set S1 = Nothing
    Set Dizi_A = Nothing
    Set Dizi_B = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

DÜŞEYARA YARDIM..

burhanyildirim11

ofis_burhan.xlsx dosyasını indir - download

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator

burhanyildirim11

burhanyildirim11

YUSUF44

Destek Ekibi

burhanyildirim11

Korhan Ayhan

Administrator