Liste Karşılaştırma

[takirti]

Daha önce ripek arkadasım yardımcı olmaya çalıştı ama uygulamaya geçiremedim malesef. Ekte bulunan örnekte iki adet liste var. İstediğim 2 listenin orjinal numaraları karşılaştırılarak fiyat farklarını 3. sayfaya yansıtması. Umarım zor değildir. Karşılaşacak bölümü kırmızı karekterlerle renklendirdim. lütfen bu sütun dikkate alınsın. Yardımlarınızı bekliyorum.

 

[Orion1]

Merhaba.
Bir modüle aşağıdaki kodları yapıştırıp çalıştırıp denermisiniz.

Sub fark()
Dim sonsat As Long, sat As Long, i As Long, fark As Double
Sheets("MASPAR").Select
Sheets("Fark").Range("A6:B65536").ClearContents
sonsat = Cells(65536, "D").End(xlUp).Row
If sonsat < 6 Then Exit Sub
sat = 6
For i = 6 To sonsat
    If Cells(i, "D").Value = "" Then GoTo atla
    Set k = Sheets("YUCESAN").Range("D10:D65536").Find(Cells(i, "D").Value, lookat:=xlWhole)
    If Not k Is Nothing Then
        fark = Cells(i, "I").Value - Sheets("YUCESAN").Cells(k.Row, "H").Value
        Sheets("Fark").Cells(sat, "A").Value = Cells(i, "D").Value
        Sheets("Fark").Cells(sat, "B").Value = fark
        sat = sat + 1
    End If
atla:
Next i
Set k = Nothing
MsgBox "İ Ş L E M   T A M A M L A N D I ::!!"
End Sub

 

[AS3434]

Daha önce ripek arkadasım yardımcı olmaya çalıştı ama uygulamaya geçiremedim malesef.

Aynen öyle.

Uygulanmış hali ekte.

 

[takirti]

Yardımlarınız için saol. Ekleri inceleyorum

 

[takirti]

Sayın sezar'ın kodlarını kullanarak oluşturduğum 2 liste arasında orjinal numaralar baz alınarak fiyat karşılaştırması gayet güzel çalışmakta fakat bazı seyler yapıldıkça malesef hedeflerde büyümektedir. Ekteki dosyada fark sayfasına 2 sayfa orjinal numaraları karşılaştırılarak fark sayfasına açıklamaları 2 sayfanın fiyatları aktarılması makro ile aktarılmasını istiyorum. Umarım konu hakkında yardımcı olacak arkadaşlar deniz gitmemiştir. Tekrar teşekkürler

 

[takirti]

Lütfen yardımlarınız esirgemeyin..

 

[tahsinanarat]

http://www.excel.web.tr/showthread.php?p=180831&posted=1#post180831 Bu adresi inceleyin, istediğiniz böyle bişeymi, doğrusu ben hangi sutunları karşılaştıracağınızı tam olarak anlamış değilim.

 

[Korhan Ayhan]

Selamlar,

Sn. Sezar beyin size önerdiği kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub fark()
Dim sonsat As Long, sat As Long, i As Long, fark As Double
Sheets("MASPAR").Select
Sheets("Fark").Range("A6:B65536").ClearContents
sonsat = Cells(65536, "D").End(xlUp).Row
If sonsat < 6 Then Exit Sub
sat = 6
For i = 6 To sonsat
    If Cells(i, "D").Value = "" Then GoTo atla
    Set k = Sheets("YUCESAN").Range("D10:D65536").Find(Cells(i, "D").Value, lookat:=xlWhole)
    If Not k Is Nothing Then
        fark = Cells(i, "I").Value - Sheets("YUCESAN").Cells(k.Row, "H").Value
        Sheets("Fark").Cells(sat, "A").Value = Cells(i, "D").Value
        Sheets("Fark").Cells(sat, "B").Value = Cells(i, "G").Value
        Sheets("Fark").Cells(sat, "C").Value = Sheets("YUCESAN").Cells(k.Row, "H").Value
        Sheets("Fark").Cells(sat, "D").Value = Cells(i, "I").Value
        Sheets("Fark").Cells(sat, "E").Value = fark
        sat = sat + 1
    End If
atla:
Next i
Set k = Nothing
MsgBox "&#304; &#350; L E M   T A M A M L A N D I ::!!"
End Sub

 

[veyselemre]

Sub fark()
Set sY = Sheets("YUCESAN")
Set sM = Sheets("MASPAR")
Set sF = Sheets("FARK")
Dim w()
Set dic = CreateObject("Scripting.Dictionary")

sY.Select
a = Range("d" & [d9].End(xlDown).Row & ":h" & [d65536].End(xlUp).Row).Value
    For x = 1 To UBound(a)
        If a(x, 1) <> Empty And a(x, 5) <> Empty Then
            If Not dic.exists(a(x, 1)) Then
                ReDim Preserve w(1 To 4)
                w(1) = a(x, 1)
                w(2) = a(x, 4)
                w(3) = a(x, 5)
                w(4) = 0
                dic.Add a(x, 1), w
            End If
        End If
    Next x
Set sY = Nothing

sM.Select
a = Range("d" & [d6].End(xlDown).Row & ":I" & [d65536].End(xlUp).Row).Value
    
    For x = 1 To UBound(a)
        If a(x, 1) <> Empty Then
                If dic.exists(a(x, 1)) Then
                    w = dic(a(x, 1))
                    w(4) = a(x, 6)
                    dic(a(x, 1)) = w
                End If
        End If
    Next x
Set sM = Nothing
Erase a
Erase w

x = dic.keys: y = dic.items
     For i = 0 To UBound(y)
          If y(i)(4) = 0 Then dic.Remove (x(i))
     Next

Erase x

y = dic.items

sF.Select
Range("A6:f65536").ClearContents
For x = 0 To UBound(y)
    Range("A6").Offset(x).Resize(, 4) = y(x)
    Range("A6").Offset(x, 4).Formula = "=RC[-2]-RC[-1]"
Next x
Set dic = Nothing
Set sF = Nothing
End Sub

 

[takirti]

Teşekkürler Sayın veyselemre ve Sayın COST_CONTROL Her 2 kod da denediğim kadar güzel çalışıyor.

 

[takirti]

Ekteki çalışmada yucesan sayfasında D sütununda boş olan satırları C sutunundan makro ile kopyalama işlemi yapmak isitiyorum. Konu hakkında yine siz değerli dostlardan yardım bekliyorum. Teşekkürler

 

[Orion1]

Merhaba.
Aşağıdaki kodlar işinizi görür.

Sub kopyala()
Dim sonsat As Long, i As Long
Sheets("YUCESAN").Select
sonsat = Cells(65536, "C").End(xlUp).Row
If sonsat < 10 Then Exit Sub
For i = 10 To sonsat
    If Cells(i, "D").Value = "" Then
        Cells(i, "D").Value = Cells(i, "C").Value
    End If
Next i
MsgBox "K O P Y A L A M A   Y A P I L D I ..!!"
End Sub

 

[takirti]

Teşekkürler Sayın Sezar

 

[Orion1]

Teşekkürler Sayın Sezar

Rica ederim.
İyi çalışmalar.

 

[takirti]

Konuyu kaldırmanız mümkünmü acaba?

 

[merken]

Konuyu kaldırmanız mümkünmü acaba?

sebep?
gayet yararli bir calismaya benziyor.

 

[takirti]

sebep?
gayet yararli bir calismaya benziyor.

Sayın Arkadaşım. Paylaşımın güzel olduğunu ve paylaşmaktan kaçan biri değilim ama bu konuyu kapatabilirsek sevinirim.