Şartı sağlayan veriyi aktar.

[manly]

Ek'te gönderdiğim dosyayı açınca ekrandaki AKTAR butonuna basılınca şunu yapmasını istiyorum.

Sayfa2 deki A sütununda ÇAP sütunundaki rakamın bir üstünü Sayfa1 deki A sütununda bulup D sütunundaki KALOT SAYISINI Sayfa2 deki B sütununa yazdırmak. Yardımcı olursanız sevinirim.

 

[Ömer]

Merhaba,

Aynı çap değeri diğer sayfada varsa yinede bir üst değerini mi arayacak.

 

[manly]

Evet aynen öyle

 

[manly]

Yardım lütfen

 

[numan şamil]

Merhaba
Olabilir mi?
Eğer en yakın olan değerler için virgülden önceki rakamları eşitse
Dener misiniz

Sub Numan()
    Dim c As Range, S1, S2 As Worksheet, ilkadres As Variant, i, x As Long
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Application.ScreenUpdating = False
    S1.Range("AA2:AB" & Rows.Count).ClearContents
      S2.Range("AA2:AB" & Rows.Count).ClearContents
    S2.Range("B2:B" & Rows.Count).ClearContents
   On Error Resume Next
 For x = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
S1.Cells(x, "AA") = Split(S1.Range("A" & x), ",")(0)
S2.Cells(x, "AA") = Split(S2.Range("A" & x), ",")(0)
S1.Cells(x, "AB") = Split(S1.Range("A" & x), ",")(1)
S2.Cells(x, "AB") = Split(S2.Range("A" & x), ",")(1)
Next x
    For i = 2 To S2.Cells(Rows.Count, "AA").End(xlUp).Row
   With S1.Range("AA2:AA" & Rows.Count)
            Set c = .Find(S2.Cells(i, "AA"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                ilkadres = c.Address
                Do
                    If S1.Cells(c.Row, "AA") = S2.Range("AA" & i) And _
                       S1.Cells(c.Row, "AB") > S2.Range("AB" & i) Then
                        S2.Cells(i, "B") = S1.Cells(c.Row, "D")
                        
                    End If
                    
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> ilkadres
            End If
        End With
    Next i
     S1.Range("AA2:AB" & Rows.Count).ClearContents
      S2.Range("AA2:AB" & Rows.Count).ClearContents
   Application.ScreenUpdating = True
End Sub

 

[manly]

Teşekkür ederim. Çok sağolun...

 

[Ömer]

Alternatif:

Sub Aktar()
    
    Dim S2 As Worksheet, son As Long, i As Long, a, c As Range
    
    Set S2 = Sheets("Sayfa2")
        
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("B2:B" & Rows.Count).ClearContents
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To S2.Cells(Rows.Count, "A").End(xlUp).Row
        a = Evaluate("=MIN(IF(A2:A" & son & ">" & S2.Cells(i, _
            "A").Address(external:=True) & ",A2:A" & son & "))")
        Set c = [A:A].Find(a, LookIn:=xlFormulas)
        If Not c Is Nothing Then
            S2.Cells(i, "B") = Cells(c.Row, "D")
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[numan şamil]

5. mesajımdaki kodlar güncellendi.

 

[manly]

Teşekkürler Ömer hocam...

 

[manly]

5. mesajımdaki kodlar güncellendi.

Çap 9,90 da sorun veriyor. Ömer hocamın Makrosunda sorun çıkmadı. İlginize teşekkürler..

 

[numan şamil]

Doğrudur
Bizim kodların doğru çalışması için
karşılaştırılacak değerlerin bir üstü için

virgülden önceki rakamları eşitse

Koşulu gerekiyor
Ömer beye bende teşekkür ederim
kodlarını arşivimize aldık.