Birden çok kritere göre aktarma

[reckly]

Herkese merhaba,

Ekte birden çok kritere göre aktarma butonu yapmaya çalıştığım ama başarılı olamadığım bir sorunumla ilgili bir dosya mevcut.Yardımlarınızı bekliyorum.

Teşekkürler

 

[Mahmut Kök]

dosyanızda oluşturacağınız bir modüle aşağıdaki kodları ekleyip deneyiniz. Sütun olarak, kodlardaki kırmızı renkli değeri değiştirmeniz yeterli olacaktır. (Bu arada, elinizdeki ürün sayısından daha fazla stok kaydı girilmiş bazı yerlerde. Onlarla ilgili de bir satır kod yazdım.)

Sub aktar()
Set s1 = Sheets(1)
Set s2 = Sheets(2)
For a = 2 To s1.[a65536].End(3).Row
urun = s1.Cells(a, "c")
stok = s1.Cells(a, "d")
mevcut = Application.WorksheetFunction.CountIf(Range("c2:c65536"), urun)
If stok > mevcut Then
al = mevcut
Else
al = stok
End If
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":[COLOR=red]d[/COLOR]" & a + (al - 1))
Set alan2 = s2.Range("a" & sonsat & ":[COLOR=red]d[/COLOR]" & sonsat + (al - 1))
alan2.Value = alan1.Value
a = a + (mevcut - 1)
Next
End Sub

 

[reckly]

bir kısıt daha

dosyanızda oluşturacağınız bir modüle aşağıdaki kodları ekleyip deneyiniz. Sütun olarak, kodlardaki kırmızı renkli değeri değiştirmeniz yeterli olacaktır. (Bu arada, elinizdeki ürün sayısından daha fazla stok kaydı girilmiş bazı yerlerde. Onlarla ilgili de bir satır kod yazdım.)

Sub aktar()
Set s1 = Sheets(1)
Set s2 = Sheets(2)
For a = 2 To s1.[a65536].End(3).Row
urun = s1.Cells(a, "c")
stok = s1.Cells(a, "d")
mevcut = Application.WorksheetFunction.CountIf(Range("c2:c65536"), urun)
If stok > mevcut Then
al = mevcut
Else
al = stok
End If
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":[COLOR=red]d[/COLOR]" & a + (al - 1))
Set alan2 = s2.Range("a" & sonsat & ":[COLOR=red]d[/COLOR]" & sonsat + (al - 1))
alan2.Value = alan1.Value
a = a + (mevcut - 1)
Next
End Sub

Sayın mesleki,

Yardımınız için çok teşekkürler.
Bu dosyaya bir kısıt daha eklersek yapılabilir mi? dosyayı inceler misiniz?

 

[reckly]

daha açıklayıcı bir dosya

sayın mesleki,

dosyada sanırım daha net bir açıklama yaptım.

teşekkürler

 

[Mahmut Kök]

Yapmak istediğiniz işlemi doğru anladığımı ümit ederek bir kod hazırladım. Eğer, 2 ürün bekleyen bir NO, beklediği ürünlerin her ikisi birden stokta yoksa, sayfa 2'ye aktarılmıyor. İnşallah doğru anlamışımdır. İyi çalışmalar dilerim.

Sub aktaralım()
Set s1 = Sheets(1)
Set s2 = Sheets(2)
For a = 2 To s1.[a65536].End(3).Row
If s1.Cells(a, "b") = 2 Then GoTo iki
tek:
urun = s1.Cells(a, "l")
stok = s1.Cells(a, "o")
kullanılan = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
If kullanılan >= stok Then GoTo tekrar
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":x" & a)
Set alan2 = s2.Range("a" & sonsat & ":x" & sonsat)
alan2.Value = alan1.Value
GoTo tekrar
iki:
urun1 = s1.Cells(a, "l")
stok1 = s1.Cells(a, "o")
kullanılan1 = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
urun2 = s1.Cells(a + 1, "l")
stok2 = s1.Cells(a + 1, "o")
kullanılan2 = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
If kullanılan1 < stok1 And kullanılan2 < stok2 Then
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":x" & a + 1)
Set alan2 = s2.Range("a" & sonsat & ":x" & sonsat + 1)
alan2.Value = alan1.Value
a = a + 1
End If
tekrar:
Next
End Sub

 

[reckly]

Çok Teşekkürler

Yapmak istediğiniz işlemi doğru anladığımı ümit ederek bir kod hazırladım. Eğer, 2 ürün bekleyen bir NO, beklediği ürünlerin her ikisi birden stokta yoksa, sayfa 2'ye aktarılmıyor. İnşallah doğru anlamışımdır. İyi çalışmalar dilerim.

Sub aktaralım()
Set s1 = Sheets(1)
Set s2 = Sheets(2)
For a = 2 To s1.[a65536].End(3).Row
If s1.Cells(a, "b") = 2 Then GoTo iki
tek:
urun = s1.Cells(a, "l")
stok = s1.Cells(a, "o")
kullanılan = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
If kullanılan >= stok Then GoTo tekrar
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":x" & a)
Set alan2 = s2.Range("a" & sonsat & ":x" & sonsat)
alan2.Value = alan1.Value
GoTo tekrar
iki:
urun1 = s1.Cells(a, "l")
stok1 = s1.Cells(a, "o")
kullanılan1 = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
urun2 = s1.Cells(a + 1, "l")
stok2 = s1.Cells(a + 1, "o")
kullanılan2 = Application.WorksheetFunction.CountIf(s2.Range("l2:l65536"), urun)
If kullanılan1 < stok1 And kullanılan2 < stok2 Then
sonsat = s2.[a65536].End(3).Row + 1
Set alan1 = s1.Range("a" & a & ":x" & a + 1)
Set alan2 = s2.Range("a" & sonsat & ":x" & sonsat + 1)
alan2.Value = alan1.Value
a = a + 1
End If
tekrar:
Next
End Sub

Sayın Mesleki,

Yardımlarınız için çok teşekkürler. Pek iyi anlatamadım ama siz tam anlamışsınız Tam ihtiyacımı karşılayan şey. Sağolun.

Visual Basic'i en iyi nasıl öğrenebilirim. Bir tavsiyeniz var mı?

İyi günler