Sütunda yazılı bilgileri ayrı sayfalarda satıra kaydetme

[kelkitli]

Merhaba Değerli Dostlar,
Bir kayıt dosyası hazırlaaya çalışıyorum. Giriş isimli sayfada B sütununa girmiş olduğum bilgileri Buton aracılığı ile B2 hücresine yazılacak işlem türüne göre A veya B sayfasına verilerin altındaki en son boş satıra kaydetmek istiyorum. Ancak yazılı olan yaka nolu kişinin o tarihe ait aynı miktarda mükerrer kaydı varsa uyarı vermesini istiyorum. Teşekkürlerimi iletirim.

 

[N.Ziya Hiçdurmaz]

Kodu bir deneyiniz.
Sub aktar()
Application.ScreenUpdating = False
Set s1 = Sheets("Giriş")
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("a1:a7")
For Each bak2 In Sheets(i).Range("b1:h1")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
bak1.Offset(0, 1).Copy
s = WorksheetFunction.CountA(Sheets(i).[h1:h65536]) + 1
bak2(s).PasteSpecial
End If
Next
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Dosyanız ektedir.
Sub aktar()
Application.ScreenUpdating = False
Set s1 = Sheets("Giriş")
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("b1:b7")
For Each bak2 In Sheets(i).Range("e1:e1000")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
MsgBox "Bu isimde bir kaydınız bulundu"
Exit Sub
End If
Next
Next
Next
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("a1:a7")
For Each bak2 In Sheets(i).Range("b1:h1")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
bak1.Offset(0, 1).Copy
s = WorksheetFunction.CountA(Sheets(i).[h1:h65536]) + 1
bak2(s).PasteSpecial
End If
Next
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[kelkitli]

Sn.V.Basic For Applications ,
Öncelikle teşekkür ederim. Kod kayıtla ilgili bölümü yapıyor. Ancak şu bilgilere ihtiyacım var. Tarih ve Miktar bilgileri hanesi boş olunca kayıt yapılmamalı. Ayrıca Yaka No Tarih ve miktar bilgileri önceden bir kez girilmişse aynı bilgiler tıpatıp aynı ise bu kayıt önceden girilmiş diye uyarmalı. Birde A ve B sayfalarının ilk sütunlarına kayıt girince otomatik sıra numarası yazmalı. Bunlar mümkün olabilirse çok memnuniyet verecek. İlgilenen arkadaşların emeğine sağlık.

 

[N.Ziya Hiçdurmaz]

Bir deneyiniz.
Sub aktar()
Application.ScreenUpdating = False
Set s1 = Sheets("Giriş")
If s1.[B3] = "" Or s1.[B5] = "" Then
MsgBox "Tarih ve Miktar bilgileri hanesi boş"
Exit Sub
End If
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("b1:b7")
For Each bak2 In Sheets(i).Range("b1:b1000")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
MsgBox "Yaka No daha önce girilmiş"
Exit Sub
End If
Next
Next
Next
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("b1:b7")
For Each bak2 In Sheets(i).Range("d1:d1000")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
MsgBox "Bu Miktar daha önce girilmiş"
Exit Sub
End If
Next
Next
Next
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("b1:b7")
For Each bak2 In Sheets(i).Range("f1:f1000")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
MsgBox "Yaka No daha önce girilmiş"
Exit Sub
End If
Next
Next
Next
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("a1:a7")
For Each bak2 In Sheets(i).Range("b1:h1")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
bak1.Offset(0, 1).Copy
s = WorksheetFunction.CountA(Sheets(i).[h1:h65536]) + 1
bak2(s).PasteSpecial
End If
Next
Next
Next
For i = 2 To Sheets.Count
For sira = 1 To WorksheetFunction.CountA(Sheets(i).Range("b1:b65536"))
Sheets(i).Range("a" & sira) = sira
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[kelkitli]

Sn.V.Basic For Applications,
Çift kayıt denetiminde şöyle bir hata var. Aynı kayıtta Yaka no, tarih, ve miktar yeni kayıtla tıpatıp aynı ise uyarmalı. Yoksa yaka nosu atıyorum 10 olan şahıs belki hergün belki günde 2 kez değişik miktarlarda teslimat yapabilecek. Birde aşağıdaki sıra ile ilgili kod hata verdi.
For sira = 1 To WorksheetFunction.CountA(Sheets(i).Range("b1:b6553 6"))

 

[N.Ziya Hiçdurmaz]

b1:b65536 Sayının arasında boşluk oluşmuş ondan hata vermiş.
For sira = 1 To WorksheetFunction.CountA(Sheets(i).Range("b1:b65536"))

 

[kelkitli]

Sn.V.Basic For Applications,
Emeğine sağlık sizi hakikaten yordum hoşgör. Mükerrer kayıt isteğimi açıklama bazında benim forumdan edindiğim bir kod var. Benim istediğim şekle uyarlayamadım ama sıkıntımı açıklamamda fikir oluşturması için dosyayı ekliyorum. Ayrıca sıra no hususunda sıralama 1.satırda başlık olduğu için 2. satırdan başlamalı.

 

[kelkitli]

Değerli Dostlar,
Açmış olduğum başlığa sağolsun arkadaşlarımız emek çektiler. Ancak kodları sonuç noktasına getiremedik. Yardımlarınızı bekliyorum.

 

[kelkitli]

Değerli Dostlar,
Sub aktar()
Application.ScreenUpdating = False
Set s1 = Sheets("Giriş")
If s1.[B3] = "" Or s1.[B5] = "" Then
MsgBox "Tarih ve Miktar bilgileri hanesi boş"
Exit Sub
End If
For i = 2 To Sheets.Count
For Each bak1 In s1.Range("a1:a7")
For Each bak2 In Sheets(i).Range("b1:h1")
If s1.[B2] = Sheets(i).Name And bak1.Value = bak2.Value Then
bak1.Offset(0, 1).Copy
s = WorksheetFunction.CountA(Sheets(i).[h1:h65536]) + 1
bak2(s).PasteSpecial
End If
Next
Next
Next
For i = 2 To Sheets.Count
For sira = 1 To WorksheetFunction.CountA(Sheets(i).Range("b1:b65536"))
Sheets(i).Range("a" & sira) = sira
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Bu kodla A ve B sayfasına aktarılan verilerimi
Sub ciftSil()
For x = [a65536].End(3).Row To 2 Step -1
If Cells(x + 1, 2).Value = Cells(x, 2).Value And Cells(x + 1, 4).Value = Cells(x, 4).Value And Cells(x + 1, 6).Value = Cells(x, 6).Value Then
Rows(x + 1).Delete
End If
Next
End Sub

şu kod ile ilgili sayfalarda teke indirmek istiyorum.
Ancak kodları birleştiremedim. Kod bilgisi yeterli olan arkadaşlar yapabilirlerse memnuniyet verir. Şimdiden teşekkür ederim.