Aynı değerleri süzüp başka çalışma sayfasına kayıt etmek

[ufukufuk01]

Merhabalar

Örnek dosyamda olduğu gibi G sütunundaki son hücreye kadar aynı kodlu verileri süzüp tüm satırları A: G hücresine kadar verileri yeni bir çalışma kitabı olarak (C: excel) klasörüne kayıt etmek istiyorum. Burada sadece süzüp yapıştırmak istiyorum her hangi bir tabloda silme ve yada toplama gibi bir işlem olmayacak. Örnek dosyada aynı çalışma sayfasına sıralamadım. Örnek tablomdan yola çıkar isek C:excel klasörüne tablosunda A1.xlsx isimli yeni bir excel sayfası B1.xlsx olarak yeni bir excel sayfası C2.xlsx olarak yeni bir excel sayfası olacak.

Şimdiden teşekkür ederim.

Ornek.xlsx dosyasını indir - download

Ornek.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[mesuttasar]

Aynı çalışma dosyasına kaydetmek için gerekli kodlar aşağıdadır.
https://s7.dosya.tc/server21/97mcx4/Ornek.xlsm.html

Sub suz()
endo = Sheet1.Cells(Rows.Count, "G").End(3).Row
Range("G2:G" & endo).Select
Selection.Copy
Cells(2, 10).PasteSpecial Paste:=xlPasteValues

 Columns("J:J").Select
 ActiveSheet.Range("$J$1:$J$100").RemoveDuplicates Columns:=1, Header:=xlNo
 Range("J1").Select
 
Call addnewsheet
Sheet1.Select

For i = 2 To endo
shf = Cells(i, 7)
Range("A" & i & ":G" & i).Select
Selection.Copy
Sheets(shf).Select
lst = Cells(Rows.Count, "A").End(3).Row + 1
Cells(lst, 1).PasteSpecial Paste:=xlPasteValues
Cells(1, 1).Select
Sheet1.Select
Next i
Columns("J:J").Select
Selection.ClearContents
 Range("A1").Select

End Sub

Sub addnewsheet()
end1 = Sheet1.Cells(Rows.Count, "J").End(3).Row
For xx = 2 To end1
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = Sheet1.Cells(xx, 10)
Next xx
 
End Sub

 

[ufukufuk01]

Hocam merhabalar

Çok teşekkür ederim elinize emeğinize sağlık.

 

[Necdet]

Merhaba,
Alternatif :

TIKLAYINIZ

4. Nolu mesaj.