Makro yardımı

[semprass]

Selamun Aleyküm

Herkeze kolay gelsin...

Arkadaşlar iki listem var arasında da bir sıra boşluk var. :yardim:

1) Üst listede olup alt listede olmayanları sayfa1'den silsin sayfa2'ye atsın.

2) Mükerrer olan kayıt.
Üst listede ve alt listede aynı olan kaydı ise sayfa1'den silsin Sayfa3'e atsın aynı zamanda farklı renge boyasın.

( ...Sesli Düşünürsem...)
Böylece;
sayfa2= (Reklamda var mağaza stokta yok)
sayfa3= (Mükerrer kayıtlar "YANİ REKLAM İÇİN SİPARİŞ AÇILACAKLAR")
kalan sayfa1= (Sipariş açılmayacaklar)

 

[semprass]

Yardım edebilecek kimse yokmu arkadaşlar

 

[semprass]

Kimse yardım etmeyecekmi.

O kadar zormu arkadaşlar.

 

[Ferhat Pazarçevirdi]

Arkadaşım deminden beri inceliyorum ama kafam basmadı sanırım İlk başta yazdım bir kod ama, sonra yine okudum sorunu, kafam karıştı

Şimdi şöyle başlayalım

1.Sorun için : Senin esas karşılaştırmak istediğin üstteki liste öyle mi?

Üstteki listedeki herbir malın altta olup olmadığını mı kontrol edeceğiz?

 

[semprass]

evet aynen dediğin gibi üst liste asıl olan liste

üstte olup altta olmayanı sayfa2 ye atacak (sayfa1'den silecek)

eğer üst listedeki ile alt listedeki sıra aynı (mükerrer) ise silip sayfa3'e atacak.

inşallah anlatabilmişimdir.

 

[Ferhat Pazarçevirdi]

Sayfa2'ye aktarma için aşağıdaki kodu denermisiniz lütfen? Eğer tamamsa devam edelim ...

Option Explicit
Sub bir()
Dim rg As Range
Dim sh1
Dim sh2
Dim sh1sonsat_ust, sh1sonsat_alt, sh2sonsat, kriter, i, j, x
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
sh1sonsat_ust = sh1.Cells(1, 1).End(xlDown).Row
sh1sonsat_alt = sh1.Cells(65536, 1).End(xlUp).Row
Set rg = Range("A1:A" & sh1sonsat_ust)
sh2.Columns("A:G").ClearContents
For i = 1 To 7
  sh2.Cells(1, i) = sh1.Cells(1, i)
Next i
sh2sonsat = sh2.Cells(65536, 1).End(xlUp).Row
For i = sh1sonsat_ust + 2 To sh1sonsat_alt
  kriter = sh1.Cells(i, 1)
  x = Application.WorksheetFunction.CountIf(rg, kriter)
  If x = 0 Then
     For j = 1 To 7
     sh2.Cells(sh2sonsat + 1, j) = sh1.Cells(i, j)
     Next j
     sh1.Rows(i).ClearContents
     sh2sonsat = sh2.Cells(65536, 1).End(xlUp).Row
  End If
Next i
End Sub

 

[semprass]

Mükemmel olmuş eğer istersen devam edebiliriz.

 

[Ferhat Pazarçevirdi]

Birincisi Tamam'sa diğerine geçelim.

Şunu da açıklarmısın biraz.

eğer üst listedeki ile alt listedeki sıra aynı (mükerrer) ise silip sayfa3'e atacak.

 

[semprass]

mükerrer olanlarıda sayfa3'e atacak ve eğer mümkünse farklı renklere boyayacak (üsttekiler mavi alttakiler yeşil gibi)

İnşallah açıklayabilmişimdir

 

[Ferhat Pazarçevirdi]

Az önceki makroyu çalıştırdıktan sonra elimizde 3 tane liste var artık.

1. Sayfa1'deki üst liste
2. Sayfa1'deki alt liste (artık ayıklanmış durumda ve boş satırlarda içeriyor)
ve
3. Sayfa2'deki liste (makroyla aktardığımız)

Şimdi;Sayfa1'deki Üst Liste ve Alt Liste zaten aynı... Yani bu kayıtlara göre hepsi mükerrer.

Mükerrerlik hangi listeler arasında kontrol edilecek?

 

[semprass]

Özür dilerim ben yanlış anlattım gerçekten özür dilerim.

Sayfa2'nin de altına başka bir liste (genel stok) yapıştıracağım yani aynı işlemi sayfa ikidede yapabilirmiyim.

 

[Ferhat Pazarçevirdi]

Aynı kodları kullanabilirsin. Tabi biraz değiştirerek .... Veri olmadığı için deneme fırsatım olmadı ama, 2.işlem için aşağıdaki gibi birşeyler olabilir.

Sub iki()
Dim rg As Range
Dim sh2, sh3, sh2sonsat_ust, sh2sonsat_alt, sh3sonsat, kriter, i, j, x
Set sh2 = Sheets("Sayfa2")
Set sh3 = Sheets("Sayfa3")
sh2sonsat_ust = sh2.Cells(1, 1).End(xlDown).Row
sh2sonsat_alt = sh2.Cells(65536, 1).End(xlUp).Row
Set rg = sh2.Range("A1:A" & sh2sonsat_ust)
sh3.Columns("A:G").ClearContents
For i = 1 To 7
  sh3.Cells(1, i) = sh2.Cells(1, i)
Next i
sh3sonsat = sh3.Cells(65536, 1).End(xlUp).Row
For i = sh2sonsat_ust + 2 To sh2sonsat_alt
  kriter = sh2.Cells(i, 1)
  x = Application.WorksheetFunction.CountIf(rg, kriter)
  If x = 0 Then
     For j = 1 To 7
       sh3.Cells(sh3sonsat + 1, j) = sh2.Cells(i, j)
     Next j
'     sh1.Rows(i).ClearContents
     sh3sonsat = sh3.Cells(65536, 1).End(xlUp).Row
  End If
Next i
Set sh2 = Nothing
Set sh3 = Nothing
Set rg = Nothing
End Sub

 

[semprass]

Çok teşekkür ederim beni 6 saatten kurtardın.