0 olan verilerin sıralamaya girmemesi

[kacik]

herkese merhaba,

Yapmaya çalıştığım bir dosyada takıldığım ufak bir noktada yardımınıza ihtiyacım var. C6 hücresine yazdığım ürün numarasına göre sayfa2'deki verilerden hangi marketlerde kaça satıldığını sayfa1'e çekmek istiyorum.

iki unsur önemli, her hafta sınırlı çeşitte ürün çıkıyor, yani bu hafta çıkan öbür haftalarda olmuyor(ürü numarası değişiyor) ve bazı marketler satılmıyor o yüzden fiyatı sıfır. Fiyatı sıfır olanların sayfa bire gelmemesi gerekiyor.

örnek dosyada ekliyorum, fikirlerinizi paylaşırsanız sevinirim.

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim k As Range, hcr As Range, sat As Long
Sheets("Sayfa1").Select
Range("A22:D65536").ClearContents
If Range("C6").Value = Empty Then
    MsgBox "İşlem Yapabilmek için C6 hücresine Bir Ürün Nosu girmelisiniz..!!", vbCritical, "UYAR"
    Range("C6").Select
    Exit Sub
End If
Application.ScreenUpdating = False
Set k = Sheets("Sayfa2").Range("G:G").Find(Range("C6").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    sat = 22
    Set alan = Sheets("Sayfa2").Range(Sheets("Sayfa2").Cells(k.Row, "L"), Sheets("Sayfa2").Cells(k.Row, _
    Sheets("Sayfa2").Cells(k.Row, 256).End(xlToLeft).Column))
    For Each hcr In alan
        If hcr.Value > 0 Then
            Cells(sat, "A").Value = sat - 21
            Cells(sat, "B").Value = Sheets("Sayfa2").Cells(9, hcr.Column)
            Cells(sat, "C").Value = hcr.Value
            sat = sat + 1
        End If
    Next hcr
End If
Set k = Nothing
Set alan = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamalandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[kacik]

sayın evren teşekkürler,

dosya oldukça güzel çalışıyor; fakat benim belirtirken bir şeyi eksik söylememden ötürü kendi dosyama entegre edemiyorum. her hafta satış yapılan market ve ürün numarası değiştiği için yazdığınız kodda standart marketler deliyor. sanırım bu da
Cells(sat, "B").Value = Sheets("Sayfa2").Cells(9, hcr.Column) kodundan kaynaklanıyor.

her hafta değişen satış yerine göre nasıl bir düzeltme yapabiliriz. ekteki dosyayı değiştirdim, oradan da bakabilirsiniz

 

[Orion1]

O şekilde olmaz sanırım.

 

[kacik]

Sayın Evren,

Sizin olmaz yanıtınızı aldıktan sonra aklıma bir çözüm yolu geldi. Her hafta değişen numaralar elimde olduğu için Sayfa1'e hafta numarası girilen bir hücresi oluşturdum(C5 hücresi) ve sizin kodlarınızda ufak iki değişiklik yaptım.

Sub aktar()
Dim k As Range, hcr As Range, sat As Long
Sheets("Sayfa1").Select
Range("A22:D65536").ClearContents
If Range("C6").Value = Empty Then
    MsgBox "İşlem Yapabilmek için C6 hücresine Bir Ürün Nosu girmelisiniz..!!", vbCritical, "UYAR"
    Range("C6").Select
    Exit Sub
End If
Application.ScreenUpdating = False
Set k = Sheets("Sayfa2").Range("G:G").Find(Range("C6").Value, , xlValues, xlWhole)
[COLOR="red"]Set j = Sheets("Sayfa2").Range("B:B").Find(Range("C5").Value, , xlValues, xlWhole)[/COLOR]
If Not k Is Nothing Then
    sat = 22
    Set alan = Sheets("Sayfa2").Range(Sheets("Sayfa2").Cells(k.Row, "L"), Sheets("Sayfa2").Cells(k.Row, _
    Sheets("Sayfa2").Cells(k.Row, 256).End(xlToLeft).Column))
    For Each hcr In alan
        If hcr.Value > 0 Then
            Cells(sat, "A").Value = sat - 21
            Cells(sat, "B").Value = Sheets("Sayfa2").Cells([COLOR="Red"]j.Row - 1[/COLOR], hcr.Column)
            Cells(sat, "C").Value = hcr.Value
            sat = sat + 1
        End If
    Next hcr
End If
Set k = Nothing
Set alan = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamalandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

Değişiklikleri kırmızı ile yazdım. Benim dosyamda işe yarıyor şu anda, teşekkürler yardımlarınızı için.

 

[Orion1]

Çözümü bulduğunuza göre mesele yok.Tebrik ederim.