• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Satır Kopyalama Hk

A

artiztttt

Katılım
12 Şubat 2012
Mesajlar
6
Excel Vers. ve Dili
2010
Öncelikle değişik olduğunu düşündüğüm bir konu var belki daha önce paylaşıldı ama forumda bulamadım. İşim gereği excelle biraz haşır neşir durumdayım sorum ise şu şekilde,

Ekte bulunan excel dosyasının içinde iline göre arayıp ve tespit edilen il örnek vermek gerekirse

İline göre arama gerçekleştirdiğinde; Aranan değer: "Adana" Eğer Adana yazan hücre bulunursa o hücrenin bulunduğu tüm satırı kopyalamanın bir yöntemi var mıdır?

içinde bulunduğu excel sayfasının yada farklı bir excel sayfası üzerine bağ yapıştır ile yapıştırmanın yöntemi var mıdır.

İlgilenen herkese şimdiden teşekkür ederim.

İyi çalışmalar.
 

Ekli dosyalar

Merhaba,

Tek tek uğraşmaktansa topluca aktarmak isterseniz aşağıdaki kodları kullanabilirsiniz.

Süz yapılacak Sütunu seçmelisiniz.

Kod: 
Sub DosyalaraAktar()
 
    Dim i           As Long, _
        SSat        As Long, _
        Sat         As Long, _
        SKol        As Integer, _
        BKol        As Integer, _
        DosyaSayfa  As Integer, _
        Secim       As Range, _
        rngAlan     As Range, _
        Liste()     As String, _
        Mesaj, _
        Yol          As String, _
        DosyaAd     As String, _
        DosyaUz     As String, _
        DosyaSy     As String, _
        Surum       As String, _
        ws          As Worksheet, _
        wsNew       As Worksheet
 
    Surum = ActiveWorkbook.FileFormat
    Set ws = Sheets(ActiveSheet.Name)
 
    On Error Resume Next
Basla:
    DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
    If DosyaSayfa = 0 Then Exit Sub
    If DosyaSayfa > 3 Then GoTo Basla
 
    Mesaj = Array("", "SAYFALARA AYRILMIŞTIR", "DOSYALARA AYRILMIŞTIR", "YAZDIRILDI")
 
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    DosyaUz = ".xlsx"
    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
 
    On Error Resume Next
    Application.DisplayAlerts = False
 
    Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
    If Secim Is Nothing Then Exit Sub
 
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
 
    Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    BKol = Secim.Column
 
    Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))
 
    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
 
    ReDim Liste(SSat - 2)
 
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
 
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    SKol = SKol - 1
 
    Selection.AutoFilter
 
    If DosyaSayfa = 1 Then
        Sheets(Liste).Delete
        For i = 0 To UBound(Liste)
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        Next i
        ws.Select
    End If
 
    For i = 0 To UBound(Liste)
        ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
        Range("A1").CurrentRegion.Copy
 
        If DosyaSayfa = 1 Then
            Sheets(Liste(i)).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ws.Select
        ElseIf DosyaSayfa = 2 Then
            Workbooks.Add
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
                 FileFormat:=Surum, CreateBackup:=False
            ActiveWorkbook.Close Savechanges:=False
        Else
            ActiveSheet.PrintOut
            Application.Wait (Now + TimeValue("0:00:02"))
        End If
    Next i
 
    ActiveSheet.ShowAllData
 
    Application.ScreenUpdating = False
    If DosyaSayfa > 3 Then GoTo Basla
 
    MsgBox Mesaj(DosyaSayfa), vbInformation, "N. YEŞERTENER...."
 
End Sub
 

Ekli dosyalar

Son düzenleme:
merhaba,

eki inceleyiniz.. Alternatif olarak , formüllerle yapılmış bir listelemedir. Ana liste çok fazla satır içerdiğinde makro kullanmak daha iyi bir çözümdür.

kolay gelsin...
 
Son düzenleme:
Öncelikle herkese teşekkür ederim.

sakman26 eklediğin dosya ile ve açıklamaların ile birlikte anladım bunun için ayrıyetten teşekkür ederim. peki bu eklediğin dosyaları acaba farklı bi excel dosyasına çıktısını alabilir miyiz yada farklı sayfalara yüzsüzlük olacak biraz ama eğer buna da bir çözüm bulabilirsek çok hayır duası alacaksın eminim :)

İyi çalışmalar.
 
artiztttt' Alıntı:
Öncelikle herkese teşekkür ederim.

sakman26 eklediğin dosya ile ve açıklamaların ile birlikte anladım bunun için ayrıyetten teşekkür ederim. peki bu eklediğin dosyaları acaba farklı bi excel dosyasına çıktısını alabilir miyiz yada farklı sayfalara yüzsüzlük olacak biraz ama eğer buna da bir çözüm bulabilirsek çok hayır duası alacaksın eminim :)

İyi çalışmalar.
Genişletmek için tıkla ...

Bizim eklediğimiz kodlar zaten bu işi yapıyordu, artizlik olsun diye mi incelemediniz.

Belki anlamazsınız diye ayrıca dosya ekledim. İster kullanın isterse kullanmayın.
 
S.A
Değerli hocam aynı mantık ile çözülebilecek benimde bir sorunum var.
Sizin verdiğiniz örnek dosyaya göre yapmaya çalıştım ama yapamadım maalesef :(

ekli dosyada yapmak istediğim;
TASLAK sayfasında Ave B sutunundaki isimlerin ayrı ayrı sayfalara karşısındaki satırları aktarmak istiyorum.
Gönderdiğim ekli dosyadaki gibi ayrı ayrı sayfalara aktarmak istiyorum. (detaylı bilgiyi dosyadada açıkladım)

Örneğin TASLAK sayfasındaki Ali Hasip D isim ile başlayan satırı Ali Hasip D Sayfasına aktarması.

Yardımlarınız için şimdiden teşekkür ederim
 

Ekli dosyalar

Son düzenleme:
merhaba keskinbıçak,

eki inceleyiniz..

kolay gelsin...
 
Son düzenleme:
Necdet Yeşertener' Alıntı:
Bizim eklediğimiz kodlar zaten bu işi yapıyordu, artizlik olsun diye mi incelemediniz.

Belki anlamazsınız diye ayrıca dosya ekledim. İster kullanın isterse kullanmayın.
Genişletmek için tıkla ...

Necdet Bey öncelikle ilginiz için teşekkür ederim. excel konusunda yüzeysel olarak bildiğim için ve kodların altına eklemiş olduğu ek'i görmediğim için size karşı mahcup oldum. Diğer arkadaşların iletmiş olduğu exceli görünce tam konuyu raks edemedim iletmiş olduğunuz excel için tekrar teşekkür ederim kodu yerleştirince tam istediğim oldu tekrardan hem size hemde sakman26 isimli arkadaşa çok teşekkür ederim. Emeğinize sağlık. tekrar kusuruma bakmayın :) iyi akşamlar.
 
merhaba keskinbıçak,

isteğiniz doğrultusunda eklemeler yapıldı ve ek , 7. no lu mesajda güncellendi....

kolay gelsin.....
 
Hocam çok özür dilerim sizi tekrar rahatsız ediyorum ama şimdi farkettim
öğrenci sayfasında sıralama öğretmen ismine göre yapmışınız.
Bunu tarihe göre sıralatmamız mümkünmü?

Çok teşekkür ederim
 
merhaba keskinbıçak,

listeleme , sizin TASLAK sayfanızdaki sıralamaya göre yapılmaktadır. Eğer ki TASLAK sayfanızı sadece TARİH sıralattırması yaparsanız istediğiniz olacaktır
kolay gelsin...
 
Anladım hocam
Çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst