Açılır listedeki seçime göre diğer sayfaya kopyalama

[_frost_]

İyi akşamlar.
Ekteki dosyada yapmak istediğim şey; "kayıt" sayfasında G den CB sütununa kadar olan bölgede açılır listeden "yanlış" veya "boş" seçeneklerinden biri seçilirse, otomatik olarak "hata" sayfasına no, Şirket Adı, Şehir, Tarih, Editor,Son İşelm Yapan ve hata yada boş olan kısım neyse onun adını otomatik olarak aşağı doğru sıralayacak bir formül ya da makroya ihtiyacım var. Bir kısmını düşeyara ile yaptım ama ihtiyacımı tam karşılamıyor çünkü no kısmını manuel girmek zorunda kalıyorum. Umarım dosya ve isteğim yeterince açıktır. Şimdiden teşekkürler.

 

[halit3]

Kayıt sayfasının kod bölümüne kopyala

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("g:cb")) Is Nothing Then Exit Sub
deg = Worksheets("kayıt").Cells(Target.Row, Target.Column).Value
If deg <> "" Then
If deg = False Or deg = "BOŞ" Then
MsgBox 2
Worksheets("hata").Cells(Target.Row, 1).Value = Worksheets("kayıt").Cells(Target.Row, 1).Value
Worksheets("hata").Cells(Target.Row, 2).Value = Worksheets("kayıt").Cells(Target.Row, 2).Value
Worksheets("hata").Cells(Target.Row, 3).Value = Worksheets("kayıt").Cells(Target.Row, 3).Value
Worksheets("hata").Cells(Target.Row, 4).Value = Worksheets("kayıt").Cells(Target.Row, 4).Value
Worksheets("hata").Cells(Target.Row, 5).Value = Worksheets("kayıt").Cells(Target.Row, 5).Value
Worksheets("hata").Cells(Target.Row, 6).Value = Worksheets("kayıt").Cells(Target.Row, 6).Value
End If
End If
End Sub

 

[İhsan Tank]

İyi akşamlar.
Ekteki dosyada yapmak istediğim şey; "kayıt" sayfasında G den CB sütununa kadar olan bölgede açılır listeden "yanlış" veya "boş" seçeneklerinden biri seçilirse, otomatik olarak "hata" sayfasına no, Şirket Adı, Şehir, Tarih, Editor,Son İşelm Yapan ve hata yada boş olan kısım neyse onun adını otomatik olarak aşağı doğru sıralayacak bir formül ya da makroya ihtiyacım var. Bir kısmını düşeyara ile yaptım ama ihtiyacımı tam karşılamıyor çünkü no kısmını manuel girmek zorunda kalıyorum. Umarım dosya ve isteğim yeterince açıktır. Şimdiden teşekkürler.

alternatif Olsun
bir module kopyalayınız

Sub hataları_aktar()
Dim a As Long
excelwebtr = MsgBox("Hataları Aktarayım Mı_?", vbYesNo + vbInformation, "Onay")
If excelwebtr = vbNo Then Exit Sub
For a = 2 To Sheets("kayıt").Cells(65536, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("kayıt").Range("G" & a & ":" & "CB" & a), False) _
Or WorksheetFunction.CountIf(Sheets("kayıt").Range("G" & a & ":" & "CB" & a), "Boş") Then
Sheets("kayıt").Cells(a, "CL") = "veri"
End If
Next a
Dim c As Range, sat As Long, ilkadres As Variant
Sheets("hata").Range("A2:K" & Rows.Count).ClearContents
sat = 2
With Sheets("kayıt").Range("CL:CL")
Set c = .Find("veri", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
ilkadres = c.Address
Do
Sheets("hata").Cells(sat, "A") = Sheets("kayıt").Cells(c.Row, "A")
Sheets("hata").Cells(sat, "B") = Sheets("kayıt").Cells(c.Row, "B")
Sheets("hata").Cells(sat, "C") = Sheets("kayıt").Cells(c.Row, "C")
Sheets("hata").Cells(sat, "D") = Sheets("kayıt").Cells(c.Row, "D")
Sheets("hata").Cells(sat, "E") = Sheets("kayıt").Cells(c.Row, "E")
Sheets("hata").Cells(sat, "F") = Sheets("kayıt").Cells(c.Row, "F")
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> ilkadres
End If
End With
Sheets("Kayıt").Range("CL2:CL65536").ClearContents
MsgBox "Hatalar Aktarıldı", vbInformation, "Bitiş"
End Sub

 

[_frost_]

ilginize çok teşekkür ederim ama verilen kodlar "hata" sayfasındaki bölüm kısmını vermiyor. Yapmak isteğim ben ne zaman G ile CB sütunları arasında boş veya yanlış seçersem bu sütununun başındaki ismi hata sayfasındaki bölüme işlemesi. Aynı satırda birden fazla bölümde hata ve boş seçimi olabilir bu nedenle ben kayıt bölümünde işlem yapmaya devam ederken otomatik olarak hata ve boş seçili hücre başlıkları da kopyalanacak. Yani diyelim G2 yanlış H2 boş seçildi.O takdirde a2 c2 d2 e2 f2 ve g2 birinci satıra, ac b2 c2 d2 e2 f2 g2 ikinci satıra hata sayfasına kopyalanacak. Karışık mı oldu acaba biraz?

 

[İhsan Tank]

bölüm kısmına neresi yazılacak açıklar mısınız kısaca

 

[_frost_]

İhsan bey dosyada iki sayfa var. Kayıt ve Hata. Kayıt sayfasının 1. satırında no,Şirket Adı, Şehir, Tarih, Editor,Son İşelm Yapan, Resmi İsmi,İsim Kaynağı,İsim Linki,Ticari ismi,Tip, Tip Kaynağı,Tip linki Alttip......... gibi isimler var. 2.satırdan itibaren eğer hücreye boş veya yanlış değeri girilirse bulunduğu satırın a-f sütunları arası + boş veya yanlış olan hücrenin adı(ilk satırda yazan) neyse onu da bölüm kısmına ben işleme devam ederken kopyalamasını istiyorum. Aynı satırda birden fazla boş ve yanlış varsa hata sayfasına alt alta sıralansın diye uğraşıyorum.

 

[halit3]

Birde bunu denermisiniz.

 

[_frost_]

bir de boş veya yanlış değerleri girilen hücrelrin en üstündeki (örn. şirket ismi) hata sayfasındaki bölüme kopyalanabilirse tam olarak yapmaya çalıştığım şey olacak. İlgilerinize çok teşekkürler.

 

[halit3]

bir de boş veya yanlış değerleri girilen hücrelrin en üstündeki (örn. şirket ismi) hata sayfasındaki bölüme kopyalanabilirse tam olarak yapmaya çalıştığım şey olacak. İlgilerinize çok teşekkürler.

gönderdiğim dosyada hata sayfasına manuel olarak elle değerleri yaz nereye ne girileceğini anlıyamadım.

yarın boş bir zamanımda bakalım

 

[_frost_]

dosya ektedir ilginize çok teşekkürler çok sağolun

 

[halit3]

dosya ektedir ilginize çok teşekkürler çok sağolun

Dosyanız ekte

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("g:cb")) Is Nothing Then Exit Sub
sat = Worksheets("hata").Cells(Rows.Count, "a").End(3).Row + 1
deg = Worksheets("kayıt").Cells(Target.Row, Target.Column).Value
If deg <> "" Then
If deg = False Or deg = "BOŞ" Then
Worksheets("hata").Cells(sat, 1).Value = Worksheets("kayıt").Cells(Target.Row, 1).Value
Worksheets("hata").Cells(sat, 2).Value = Worksheets("kayıt").Cells(Target.Row, 2).Value
Worksheets("hata").Cells(sat, 3).Value = Worksheets("kayıt").Cells(Target.Row, 3).Value
Worksheets("hata").Cells(sat, 4).Value = Worksheets("kayıt").Cells(Target.Row, 4).Value
Worksheets("hata").Cells(sat, 5).Value = Worksheets("kayıt").Cells(Target.Row, 5).Value
Worksheets("hata").Cells(sat, 6).Value = Worksheets("kayıt").Cells(Target.Row, 6).Value
Worksheets("hata").Cells(sat, 7).Value = Worksheets("kayıt").Cells(1, Target.Column).Value
End If
End If
End Sub

 

[_frost_]

Ellerinize sağlık tam istediğim gibi oldu şimdi. Büyüksünüz...

 

[_frost_]

efendim peki "bos" ya da "yanlis" olan degerler dogru ya da uygulanamaz olarak degistirilirse "hata" sayfasindan o kismi otomatik sildirmek mumkun mu? Ornek: kayit sayfasinda ikinci satirda Isim sutunu bos olarak islendi ve excel otomatik olarak bunu "hata" sayfasina aktardi. Ama anladikki aslinda "dogru" olarak islenmesi gerekiyormus. Biz islemi dogru olarak degistirince "hata" sayfasindaki ilgili satir otomatik silinecek. Klavyemden dolayi Turkce karakterleri yazamadim ozur diliyorum.

 

[halit3]

efendim peki "bos" ya da "yanlis" olan degerler dogru ya da uygulanamaz olarak degistirilirse "hata" sayfasindan o kismi otomatik sildirmek mumkun mu? Ornek: kayit sayfasinda ikinci satirda Isim sutunu bos olarak islendi ve excel otomatik olarak bunu "hata" sayfasina aktardi. Ama anladikki aslinda "dogru" olarak islenmesi gerekiyormus. Biz islemi dogru olarak degistirince "hata" sayfasindaki ilgili satir otomatik silinecek. Klavyemden dolayi Turkce karakterleri yazamadim ozur diliyorum.

Bu kodu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("g:cb")) Is Nothing Then Exit Sub
Set Sh1 = Sheets("kayıt")
Set Sh2 = Sheets("hata")
sat = Sh2.Cells(Rows.Count, "a").End(3).Row + 1
deg = Sh1.Cells(Target.Row, Target.Column).Value
If deg <> "" Then
If deg = False Or deg = "BOŞ" Then
Sh2.Cells(sat, 1).Value = Sh1.Cells(Target.Row, 1).Value
Sh2.Cells(sat, 2).Value = Sh1.Cells(Target.Row, 2).Value
Sh2.Cells(sat, 3).Value = Sh1.Cells(Target.Row, 3).Value
Sh2.Cells(sat, 4).Value = Sh1.Cells(Target.Row, 4).Value
Sh2.Cells(sat, 5).Value = Sh1.Cells(Target.Row, 5).Value
Sh2.Cells(sat, 6).Value = Sh1.Cells(Target.Row, 6).Value
Sh2.Cells(sat, 7).Value = Sh1.Cells(1, Target.Column).Value
Else
aranan1 = Sh1.Cells(Target.Row, 1).Value
aranan2 = Sh1.Cells(Target.Row, 2).Value
aranan3 = Sh1.Cells(Target.Row, 3).Value
aranan4 = Sh1.Cells(Target.Row, 4).Value
aranan5 = Sh1.Cells(Target.Row, 5).Value
aranan6 = Sh1.Cells(Target.Row, 6).Value
aranan7 = Sh1.Cells(1, Target.Column).Value
aranan8 = aranan1 & aranan2 & aranan3 & aranan4 & aranan5 & aranan6 & aranan7
For i = Sh2.[a65536].End(3).Row To 2 Step -1
bulunan1 = Sh2.Cells(i, 1).Value
bulunan2 = Sh2.Cells(i, 2).Value
bulunan3 = Sh2.Cells(i, 3).Value
bulunan4 = Sh2.Cells(i, 4).Value
bulunan5 = Sh2.Cells(i, 5).Value
bulunan6 = Sh2.Cells(i, 6).Value
bulunan7 = Sh2.Cells(i, 7).Value
bulunan8 = bulunan1 & bulunan2 & bulunan3 & bulunan4 & bulunan5 & bulunan6 & bulunan7
If aranan8 = bulunan8 Then
Sh2.Rows(i).Delete
End If
Next i

End If
End If
End Sub

 

[_frost_]

Efendim sizlere yardimlarinizdan dolayi ne kadar tesekkur etsem az. Cok sagolun. Son haliyle gayet guzel calisiyor.

 

[halit3]

Efendim sizlere yardimlarinizdan dolayi ne kadar tesekkur etsem az. Cok sagolun. Son haliyle gayet guzel calisiyor.

iyi çalışmalar