Unvana Göre Oranı Bul ve Değiştir

[Kemter]

Esselamuanaleykum sevgili form dostlarım makro bilgim olmadığı için ekteki dosyaya kod yazma imkanı olabilir mi? Gerekli açıklamalar dosya içerisinde örnekli olarak anlatmaya çalıştım. Hayırlı akşamlar.

 

[Asri]

Aleykumselam,
Liste sayfasında C2 ye aşağıdaki formülü yapıştırın köşesinden tutup aşağı çekin.

=EĞER(VE(B2>=DÜŞEYARA(A2;Veri!A:D;2;0);B2<=DÜŞEYARA(A2;Veri!A:D;3;0));DÜŞEYARA(A2;Veri!A:D;4;0);0)

 

[Kemter]

Allah razı olsun formül olarak işlem tamam, mümkün ise vba kodu ile kullanmak istemiştim. Selametle kalınız.

 

[turist]

Makro uygulanan dosyanız eklidir.

 

[Kemter]

Makro uygulanan dosyanız eklidir.

Ellerine emeğine sağlık rabbim senden ebeden razı olsun. Hayırlı günler.

 

[turist]

Güzel duanıza çok teşekkür ederim, sağ olun.

 

[Kemter]

turist bey merhabalar sizden bir istirhamım olabilir mi?
mesaj 4 deki dosyadaki kodu unvana göre olan değerleri VERİ sayfasındaki B, C ve D sütunundaki değerlere göre Liste sayfasındaki C sütununa yazdırma kodunu güncelleyebilir misini?
İyi akşamlar.

 

[Korhan Ayhan]

Tam olarak ne istiyorsunuz?

 

[Kemter]

Mesaj 4 deki dosyadaki kodu VERİ sayfasındaki B, C arasındaki değerleri D sütunundaki değerleri, Liste sayfasındaki B sütunundaki değerlere göre C sütununa VERİ sayfasındaki D sütunundaki verileri yazdırmak istiyorum?
İlginiz için teşekkür ederim.

 

[Kemter]

Ekli dosyada da açıklama yapmaya çalıştım inşallah anlatabilmişimdir.
Örnek 1 ile 5 olanların hepsi Liste sayfasının B sütunda olan değeri karşılık gelen değerin yenisi C Sutünuna yazdırmak istiyorum.
Örnek: 21 ile 25 arası olan değerilerin hepsi 6 olacak şekilde LİSTE sayfasındaki C sutünuna yazdırmak istiyorum.
Değerler küçük veya büyük ise 0(sıfır) olabilir hiç olmasa hatalı kayıtları bulunmuş olur.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Fast_Vlookup()
    Dim Zaman As Double, Dizi As Variant, X As Long, Veri_A As Integer, Veri_B As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Sheets("Liste").Range("C2:C" & Rows.Count).ClearContents
    
    Dizi = Sheets("Veri").Range("A1").CurrentRegion.Resize(, 4).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)
        Next
        
        Dizi = Sheets("Liste").Range("A1").CurrentRegion.Resize(, 3).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Veri_A = Split(.Item(Dizi(X, 1)), "#")(0)
                Veri_B = Split(.Item(Dizi(X, 1)), "#")(1)
                If Dizi(X, 2) >= Veri_A And Dizi(X, 2) <= Veri_B Then
                    Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(2)
                Else
                    Dizi(X, 3) = "Yok"
                End If
            Else
                Dizi(X, 3) = "Yok"
            End If
        Next
    End With
    
    Sheets("Liste").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("Liste").Range("A1").CurrentRegion.Resize(, 3) = Dizi
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub

 

[Kemter]

Deneyiniz.

Option Explicit

Sub Fast_Vlookup()
    Dim Zaman As Double, Dizi As Variant, X As Long, Veri_A As Integer, Veri_B As Integer
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Zaman = Timer
  
    Sheets("Liste").Range("C2:C" & Rows.Count).ClearContents
  
    Dizi = Sheets("Veri").Range("A1").CurrentRegion.Resize(, 4).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)
        Next
      
        Dizi = Sheets("Liste").Range("A1").CurrentRegion.Resize(, 3).Value
      
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Veri_A = Split(.Item(Dizi(X, 1)), "#")(0)
                Veri_B = Split(.Item(Dizi(X, 1)), "#")(1)
                If Dizi(X, 2) >= Veri_A And Dizi(X, 2) <= Veri_B Then
                    Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(2)
                Else
                    Dizi(X, 3) = "Yok"
                End If
            Else
                Dizi(X, 3) = "Yok"
            End If
        Next
    End With
  
    Sheets("Liste").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("Liste").Range("A1").CurrentRegion.Resize(, 3) = Dizi
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub

Korhan bey emeğinize sağlık, şöyle bir durum oldu kısmi olarak çalışıyor. Ekran Görütüsü ekte.

Örnek:6 10 arası olan rakamları tamamını 3 ile değişmesi gerekiyor.
Yeni Dosyayı mesaj 10 ekledim.

 

[Korhan Ayhan]

Ben ilk mesajınızdaki dosyaya göre kod önermiştim. Son dosyanızda durum farklı görünüyor. Müsait olduğumda dönüş yaparım.

 

[Kemter]

Ben ilk mesajınızdaki dosyaya göre kod önermiştim. Son dosyanızda durum farklı görünüyor. Müsait olduğumda dönüş yaparım.

Korhan bey yazmış olduğunuz kod çok güzel olmuş ve mükemmel hızlı çalışıyor.
Yeni kod içinde şimdiden teşekkür ederim.
İlginiz ve alakanız için Allah razı olsun.

 

[Korhan Ayhan]

Eklediğiniz dosyada UNVAN kısmı boş görünüyor. Bu şekilde mi kullanacaksınız.

Çünkü benim önerdiğim kodlama bu sütunu dikkate alarak işlem yapıyordu.

 

[Kemter]

Eklediğiniz dosyada UNVAN kısmı boş görünüyor. Bu şekilde mi kullanacaksınız.

Çünkü benim önerdiğim kodlama bu sütunu dikkate alarak işlem yapıyordu.

Evet UNVAN kısmı boş olacak değerlere göre olabilirse memnun olurum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Fast_Vlookup()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim Zaman As Double, Dizi As Variant, Y As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Liste")
    
    S2.Range("C2:C" & S2.Rows.Count).ClearContents
    
    Dizi = S1.Range("A1:D" & WorksheetFunction.Max(S1.Range("B:C"))).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            For Y = Dizi(X, 2) To Dizi(X, 3)
                .Item(Y) = Dizi(X, 4)
            Next
        Next
        
        Dizi = S2.Range("A1").CurrentRegion.Resize(, 3).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 2)) Then
                Dizi(X, 3) = .Item(Dizi(X, 2))
            Else
                Dizi(X, 3) = "Yok"
            End If
        Next
    End With
    
    S2.Range("A2:A" & S2.Rows.Count).NumberFormat = "@"
    S2.Range("A1").CurrentRegion.Resize(, 3) = Dizi
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub

 

[Kemter]

Korhan bey emeğinize sağlık çok güzel olmuş ve hızlı çalışıyor.
Bu kodu dosyadaki liste butonuna bastığımda çalıştıramıyorum. Vba bilgim olmadığı için bunun için buton eklene bilinir mi?
Kolay gelsin.

 

[Korhan Ayhan]

Zorluk yaşamamanız için bu tarz işlemleri öğrenmenizi tavsiye ederim.

Linkleri inceleyerek yapmaya çalışın.

https://www.excel.web.tr/threads/moduel-ekleme-resimli-anlatim.73353/

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-1-resimli-anlatim.59436/

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-2-resimli-anlatim.136979/

https://www.excel.web.tr/threads/sayfada-commandbutton-olusturmak-ve-makro-atamak-resimli-anlatim.68065/

 

[Kemter]

Korhan Bey emeğinize sağlık Allah razı olsun.
Vermiş olduğunuz linkleri inceleyerek yapamaya çalışacağım.
Selametle kalınız.