• DİKKAT

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

2 sayfa arasında arama

C

conari

Katılım
2 Mart 2007
Mesajlar
603
Excel Vers. ve Dili
2003
Merhaba arkadaşlar yine uzun zamandır burada değildim.

Ekte örnek olarak ekledim çalışmada yardıma ihtiyacım var.
Açıklamayı örnekte yaptım burada kısaca yazayım yazılan kod başka bir sayfadan aranıp adresi alınacak.

Şimdiden örnekler için tşk.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodu dener misiniz?

Kod;
Kod: 
Option Explicit
Sub VERİ_BUL()
Dim U As Long, S1 As Worksheet, S2 As Worksheet, Bul As Range, Adres As String
Set S1 = Sheets("Liste")
Set S2 = Sheets("detay")
S2.Range("C3:C65536") = ""
    For U = 3 To S2.[A65536].End(3).Row
        Set Bul = S1.Cells.Find(what:=S2.Cells(U, "A"), LookAt:=xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    S2.Cells(U, "C") = S2.Cells(U, "C") & S1.Cells(Bul.Row, "A") & "-" & S1.Cells(Bul.Row, "C") & ", "
                    Set Bul = S1.Cells.FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
    Next
MsgBox "İşleminiz tamamlanmıştır !", vbInformation
End Sub
 
Merhaba,

Aşağıdaki kodları deneyiniz.

Kod: 
Sub Bul()
    Dim Bul     As Range
    Dim Adr1    As String
    Dim i       As Long
    Dim Miktar  As Double
    Dim Adet    As Integer
    Dim sL      As Worksheet
    Dim sD      As Worksheet
    Dim SonSat  As Long
    
    Set sL = Sheets("Liste")
    Set sD = Sheets("detay")
    
    sD.Select
    SonSat = sD.[A65536].End(3).Row
    Application.ScreenUpdating = False
    sD.Range("C3:C" & SonSat).ClearContents
    
    For i = 3 To SonSat
        Miktar = 0
        Adet = 0
        With sL.Range("B:B")
            Set Bul = .Find(sD.Cells(i, "A"), LookIn:=xlValues, Lookat:=xlWhole)
            If Not Bul Is Nothing Then
                Adr1 = Bul.Address
                Do
                    If (Miktar) <= sD.Cells(i, "B") Then
                        Adet = Adet + 1
                        Miktar = Miktar + sL.Cells(Bul.Row, "C")
                        If Adet = 1 Then
                            sD.Cells(i, "C") = sL.Cells(Bul.Row, "A") & " - " & sL.Cells(Bul.Row, "C")
                        Else
                            sD.Cells(i, "C") = sD.Cells(i, "C") & ", " & sL.Cells(Bul.Row, "A") & " - " & sL.Cells(Bul.Row, "C")
                        End If
                    Else
                        Exit Do
                    End If
                    
                    Set Bul = .FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adr1
            End If
        End With
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlandı.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL] ny"
    
    
End Sub
 

Ekli dosyalar

sayın conari: cok şanslısınız galiba bir alternatif çözümde benden

kodları detay sayfasına koyunuz a hücresi ve b hücresi dolu olmak kayıdıyla a hücresindeki değere göre veriyi buluyor.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
a = Target.Row
b = Target.Column
If Cells(a, 1).Value <> "" Then
If Cells(a, 2).Value <> "" Then
ad = Cells(a, 1).Value
If ad <> Empty Then
Set d = Worksheets("Liste").Range("B2:B" & Worksheets("Liste").Cells(Rows.Count, "b").End(3).Row).Find(ad, LookAt:=xlWhole)
If Not d Is Nothing Then
firstAddress = d.Address
Do
If deg = "" Then
deg = deg & Worksheets("Liste").Cells(d.Row, 1) & "-" & Worksheets("Liste").Cells(d.Row, 3)
Else
deg = deg & ", " & Worksheets("Liste").Cells(d.Row, 1) & "-" & Worksheets("Liste").Cells(d.Row, 3)
End If
Set d = Worksheets("Liste").Range("B2:B" & Worksheets("Liste").Cells(Rows.Count, "b").End(3).Row).FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstAddress
End If
End If
Cells(a, 3).Value = deg
End If
End If
End Sub
Genişletmek için tıkla ...
 
Selam, hepinize teşekkürler.
Kodun komut ile olması daha çok işime geliyor. ondan hücre değişimini denemedim.

diğerleri güzel çalışıyor. Sadece fazlalığı var. :) verilen Miktardan fazlasını görmek istemiyorum. Yani YK4 için D - 30, K - 20 cevabını almalıyım.
 
conari' Alıntı:
Selam, hepinize teşekkürler.
Kodun komut ile olması daha çok işime geliyor. ondan hücre değişimini denemedim.

diğerleri güzel çalışıyor. Sadece fazlalığı var. :) verilen Miktardan fazlasını görmek istemiyorum. Yani YK4 için D - 30, K - 20 cevabını almalıyım.
Genişletmek için tıkla ...

Benim kodlarımın uzun olmasının nedeni de o zaten :)
 
conari' Alıntı:
Necdet bey sizinki kısmen daha yakın fakat, Miktardan fazlasını gösteriyor ben göstermemesini istiyorum.

Yani YK4 için 50 adet girilmiş.
D - 30,
K - 20 cevabını almalıyım. K- 50 olarak göstermemeli. :)
Genişletmek için tıkla ...

Açıklamalrınızdan ancak o kadar anlamıştım :)

Şimdi söylüyorsunuz ihtiyacımız kadar gelsin diye :)
 
Merhaba,

İsteğe göre düzeltilmiş hali aşağıdadır.

Kod: 
Sub Bul()
    Dim Bul     As Range
    Dim Adr1    As String
    Dim i       As Long
    Dim Miktar  As Double
    Dim Tutar   As Double
    Dim sL      As Worksheet
    Dim sD      As Worksheet
    Dim SonSat  As Long
    
    Set sL = Sheets("Liste")
    Set sD = Sheets("detay")
    
    sD.Select
    SonSat = sD.[A65536].End(3).Row
    Application.ScreenUpdating = False
    sD.Range("C3:C" & SonSat).ClearContents
    
    For i = 3 To SonSat
        Miktar = 0
        With sL.Range("B:B")
            Set Bul = .Find(sD.Cells(i, "A"), LookIn:=xlValues, Lookat:=xlWhole)
            If Not Bul Is Nothing Then
                Adr1 = Bul.Address
                Do
                    Tutar = sL.Cells(Bul.Row, "C")
                    If (Miktar + Tutar) > sD.Cells(i, "B") Then Tutar = sD.Cells(i, "B") - Miktar
                    Miktar = Miktar + Tutar
                    If Len(sD.Cells(i, "C")) = 0 Then
                        sD.Cells(i, "C") = sL.Cells(Bul.Row, "A") & " - " & Tutar
                    Else
                        sD.Cells(i, "C") = sD.Cells(i, "C") & ", " & sL.Cells(Bul.Row, "A") & " - " & Tutar
                    End If
                    If Miktar = sD.Cells(i, "B") Then Exit Do
                    Set Bul = .FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adr1
            End If
        End With
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlandı.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL] ny"
    
End Sub
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst