• DİKKAT

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

Hücre Değerine Göre Farklı Sayfalara Satır Kopyalama

H

hturkavci03

Katılım
12 Mart 2011
Mesajlar
35
Excel Vers. ve Dili
Excel 2003 Türkçe
Merhaba, Excel bilgim orta seviyelerde ancak kod seviyem çok düşük. Bir konuda yardıma ihtiyacım var.

Bir Excel çalışma kitabında Sayfa1'de alt alta kayıtlar yapacağım. Bu kayıtları örneğin H sütununda belirleyeceğim 8-10 kadar değerlere göre Sayfa2, Sayfa3.... Sayfa11'de altalta kopyalamak istiyorum.
Kayıtlar yıl içerisinde peyderpey yapılacağından her yani kayıt ilgili sütun değerine göre ilişkili olduğu sayfada kaydın kaldığı yere kopyalanmalı. Yani yapılan kayıtların tümünü Sayfa1'de, H sütunundaki değerlere göre diğer sayfalarda görmem gerekli. Sanırım dosya yükleme yetkim yok, yapamadım. Şimdiden yardımlarınız için teşekkür ederim.
 
Merhaba,
Forum sayfasına dosya yükleme yetkiniz yok ama "dosya.tc" sitesine yükleme yaparak link verebilirsiniz.
 
Dediğiniz kolayca yapılabilir ama kod yazmak için dosyanızı görmem gerek. Aşağıda istediğiniz şeylerin kodlarını yazıyorum. Kendinize göre düzenleyerek de kullanabilirsiniz.

Sayfa 1'in son satırını bulma
Kod: 
Sayfa1.Range("A62652").End(3).Row

Yazdığımız değere göre diğer sayfalara dağılması
NOT: A2'ye 1 yazarsam Sayfa2'ye, 2 yazasam Sayfa3'e değerin son satırın altına yazmasını istersem kodum aşağıdaki gibi olmalı.
Kod: 
Private Sub WokSheets_Change (Byval Target As Range)
If Sayfa1.Range("A2").Value = 1 Then
Sayfa2.Range("A" & Sayfa2.Range("A65652").Row +1).Value = Sayfa1.Range("A2").Value
ElseIs Sayfa1.Range("A2").Value = 2 Then
Sayfa2.Range("A" & Sayfa3.Range("A65652").Row +1).Value = Sayfa1.Range("A2").Value
End If

Bu kodda
Kod: 
 Sayfa2.Range("A65652").Row +1
yazdığım kısım, Sayfa2'deki A'nın son yazılı hücresini bulur ve onun altına veriyi işler.
 
İlk ve son verdiğiniz kodları hangi olay yordamına ve hangi sayfaya yazmam gerekli acaba.
 
Bir de koşul sütunu E sütunu ve anladığım kadarıyla değer yazacağım hücre sizin veriğiniz kodlarda A2 olarak sabit. Benim istediğim E sütununda en son yazılan değere göre o satırın kopyalanması.
 
Merhaba,
Sayfanızın sekmesine sağ tıklayın, "Kod görüntüle" seçin
Açılan kod penceresine aşağıdaki kodları yapıştırın, imleciniz kod satırlarının arasında bir yerlerde iken F5 e tıklayın.
Excel kod arayüzünü biraz kullanmasını biliyorsanız, Ana sayfaya bir düğme çizip sağ tıklayın >> "Makro Ata" seçeneği ile sihirbaz yardımı ile kodu seçin. Böylece düğmeye kod atamış olacaksınız. Kodlarınız aşağıdadır.
Kod: 
Sub verilerin_hepsini_getir()
Dim syf As Worksheet, i As Byte, ss As Long, sat As Integer, _
    x As Long, alan As Range, sh As Worksheet

Set sh = Sheets("ANA SAYFA")
sat = 2
sh.Range("A2:E5000").ClearContents
For i = 2 To Sheets.Count
    Set syf = Sheets(i)
    ss = syf.Range("B" & Rows.Count).End(3).Row
    For x = 2 To ss
        Set alan = syf.Range("A" & x & ":E" & x)
        sh.Range("A" & sat).Resize(1, 5).Value = alan.Value
        sat = sat + 1
    Next x
Next i
MsgBox "İşlem tamamlandı..", vbInformation, "antonio"
End Sub
 
https://www.dosyaupload.com/5btx

Örnek dosyanız bu. Kullandığım kodlar Aşağıda. Alt+F11 ile kod bölümüne girin. Sayfa1'i çift tıklatın. Orada kodları görebilirsiniz.

Kod: 
Sub taşı()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

son = Range("A65652").End(3).Row



For v = 2 To son
son1 = Sheets("USTA-1").Range("B65652").End(3).Row
son2 = Sheets("USTA-2").Range("B65652").End(3).Row
son3 = Sheets("USTA-3").Range("B65652").End(3).Row
son4 = Sheets("USTA-4").Range("B65652").End(3).Row
If Range("E" & v).Value = "USTA-1" Then
Range("B" & v, "E" & v).Copy
Sheets("USTA-1").Range("B" & son1 + 1).PasteSpecial
Application.CutCopyMode = False
ElseIf Range("E" & v).Value = "USTA-2" Then
Range("B" & v, "E" & v).Copy
Sheets("USTA-2").Range("B" & son2 + 1).PasteSpecial
Application.CutCopyMode = False
ElseIf Range("E" & v).Value = "USTA-3" Then
Range("B" & v, "E" & v).Copy
Sheets("USTA-3").Range("B" & son3 + 1).PasteSpecial
Application.CutCopyMode = False
ElseIf Range("E" & v).Value = "USTA-4" Then
Range("B" & v, "E" & v).Copy
Sheets("USTA-4").Range("B" & son4 + 1).PasteSpecial
Application.CutCopyMode = False
End If
Next v

son1 = Sheets("USTA-1").Range("B65652").End(3).Row
son2 = Sheets("USTA-2").Range("B65652").End(3).Row
son3 = Sheets("USTA-3").Range("B65652").End(3).Row
son4 = Sheets("USTA-4").Range("B65652").End(3).Row

'Sheets("USTA-1").Range("A2:A" & son1).ClearContents
'Sheets("USTA-2").Range("A2:A" & son2).ClearContents
'Sheets("USTA-3").Range("A2:A" & son3).ClearContents
'Sheets("USTA-4").Range("A2:A" & son4).ClearContents

yer = 1
For y = 2 To son1
Sheets("USTA-1").Range("A" & y).Value = yer
yer = yer + 1
Next y

For a = 2 To son2
Sheets("USTA-2").Range("A" & a).Value = a - 1
Next a

For b = 2 To son3
Sheets("USTA-3").Range("A" & b).Value = b - 1
Next b

For c = 2 To son4
Sheets("USTA-4").Range("A" & c).Value = c - 1
Next c


MsgBox "İşlem Başarıyla Tamamlandı.", vbOKOnly + vbInformation, "İŞLEM TAMAMLANDI"
End Sub
 
Merhaba, ilginize çok teşekkürler.

Sayın TanerSaydam örnek dosyayı inceledim. İşlemi istediğim gibi yapıyor ancak ANA SAYFA'ya yeni kayıt ekleyip (örneğin USTA-4) AKTAR dediğimde önceki kopyalanmış USTA-4 kaydı ile birlikte aktarma yapıyor ve USTA-1 sayfasında mükerrer kayda neden oluyor.

Sayın antonio, verdiğiniz kodları dosyaya uyguladım. Makroyu çalıştırdığımda ANA sayfadaki kayıtlar kayboluyor ve diğer sayfalara kayıt gelmiyor.
 
hturkavci03' Alıntı:
Merhaba, ilginize çok teşekkürler.
Sayın antonio, verdiğiniz kodları dosyaya uyguladım. Makroyu çalıştırdığımda ANA sayfadaki kayıtlar kayboluyor ve diğer sayfalara kayıt gelmiyor.
Genişletmek için tıkla ...

Benim yazdığım kodlar, 2.sayfadan son sayfaya kadar (anasayfa hariç) verileri toplayıp anasayfaya işliyor.
İstediğiniz bu değil miydi?
 
Sayın antonio, yapmak isteiğim bunun tam tersi idi. ANA SAYFA daki kayıtları E sütununa göre ilgili sayfalara kopyalamak. Her yeni kayıtta sadece yeni kaydı güncellemesi idi.
 
Alternatif olsun;
Kod: 
Sub Kayıtekle()
Application.ScreenUpdating = False
Dim t As Integer
Dim k As Integer
On Error GoTo çıkış
sonsat1 = Sheets("ANA SAYFA").Range("A65500").End(3).Row

Sheets("ANA SAYFA").Range("F2:F6").ClearContents
For Each C In Sheets
    Sheets("ANA SAYFA").Range("F65536").End(3).Offset(1, 0) = C.Name
    Next

 s1 = Sheets("ANA SAYFA").Range("F3")
 s2 = Sheets("ANA SAYFA").Range("F4")
 s3 = Sheets("ANA SAYFA").Range("F5")
 s4 = Sheets("ANA SAYFA").Range("F6")

Sheets(s1).Range("A2:E" & Sheets(s1).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s2).Range("A2:E" & Sheets(s2).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s3).Range("A2:E" & Sheets(s3).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s4).Range("A2:E" & Sheets(s4).Range("A65500").End(3).Row + 1).ClearContents
    
    k = 2
    
    Sayfaadı = Sheets("ANA SAYFA").Range("E" & k)
bas:
Sayfaadı = Sheets("ANA SAYFA").Range("E" & k)

t = Sheets(Sayfaadı).Range("A65500").End(3).Row + 1

    Sheets(Sayfaadı).Range("A" & t) = Sheets("ANA SAYFA").Range("A" & k)
    Sheets(Sayfaadı).Range("B" & t) = Sheets("ANA SAYFA").Range("B" & k)
    Sheets(Sayfaadı).Range("C" & t) = Sheets("ANA SAYFA").Range("C" & k)
    Sheets(Sayfaadı).Range("D" & t) = Sheets("ANA SAYFA").Range("D" & k)
    Sheets(Sayfaadı).Range("E" & t) = Sheets("ANA SAYFA").Range("E" & k)

    k = k + 1

    If k < sonsat1 + 1 Then GoTo bas

Sheets("ANA SAYFA").Select
Range("A1").Select
Application.ScreenUpdating = True
         MsgBox "İşlem Tamam", vbInformation
çıkış:
End Sub
 
Son düzenleme:
Tekrar Merhaba,

Sayın çıtır, verdiğiniz kodları aşağıdaki gibi değiştirerek F sütunundaki verileri gözden uzak bir yere aldım ve istediğim gibi çalışıyor. Çok teşekkür ederim.


Sub taşı()
Application.ScreenUpdating = False
Dim t As Integer
On Error GoTo çıkış
sonsat1 = Sheets("ANA SAYFA").Range("A65500").End(3).Row

Sheets("ANA SAYFA").Range("XFD2:XFD10").ClearContents
For Each C In Sheets
Sheets("ANA SAYFA").Range("XFD65536").End(3).Offset(1, 0) = C.Name
Next

s1 = Sheets("ANA SAYFA").Range("XFD3")
s2 = Sheets("ANA SAYFA").Range("XFD4")
s3 = Sheets("ANA SAYFA").Range("XFD5")
s4 = Sheets("ANA SAYFA").Range("XFD6")
s5 = Sheets("ANA SAYFA").Range("XFD7")
s6 = Sheets("ANA SAYFA").Range("XFD8")
s7 = Sheets("ANA SAYFA").Range("XFD9")
s8 = Sheets("ANA SAYFA").Range("XFD10")

Sheets(s1).Range("A2:E" & Sheets(s1).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s2).Range("A2:E" & Sheets(s2).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s3).Range("A2:E" & Sheets(s3).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s4).Range("A2:E" & Sheets(s4).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s5).Range("A2:E" & Sheets(s5).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s6).Range("A2:E" & Sheets(s6).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s7).Range("A2:E" & Sheets(s7).Range("A65500").End(3).Row + 1).ClearContents
Sheets(s8).Range("A2:E" & Sheets(s8).Range("A65500").End(3).Row + 1).ClearContents

k = 2

Sayfaadı = Sheets("ANA SAYFA").Range("E" & k)
bas:
Sayfaadı = Sheets("ANA SAYFA").Range("E" & k)

t = Sheets(Sayfaadı).Range("A65500").End(3).Row + 1

Sheets(Sayfaadı).Range("A" & t) = Sheets("ANA SAYFA").Range("A" & k)
Sheets(Sayfaadı).Range("B" & t) = Sheets("ANA SAYFA").Range("B" & k)
Sheets(Sayfaadı).Range("C" & t) = Sheets("ANA SAYFA").Range("C" & k)
Sheets(Sayfaadı).Range("D" & t) = Sheets("ANA SAYFA").Range("D" & k)
Sheets(Sayfaadı).Range("E" & t) = Sheets("ANA SAYFA").Range("E" & k)
Sheets(Sayfaadı).Range("F" & t) = Sheets("ANA SAYFA").Range("F" & k)
Sheets(Sayfaadı).Range("G" & t) = Sheets("ANA SAYFA").Range("G" & k)
Sheets(Sayfaadı).Range("H" & t) = Sheets("ANA SAYFA").Range("H" & k)
Sheets(Sayfaadı).Range("I" & t) = Sheets("ANA SAYFA").Range("I" & k)
Sheets(Sayfaadı).Range("J" & t) = Sheets("ANA SAYFA").Range("J" & k)
Sheets(Sayfaadı).Range("K" & t) = Sheets("ANA SAYFA").Range("K" & k)
Sheets(Sayfaadı).Range("L" & t) = Sheets("ANA SAYFA").Range("L" & k)

k = k + 1

If k < sonsat1 + 1 Then GoTo bas

Sheets("ANA SAYFA").Select
Range("C1").Select
Application.ScreenUpdating = True

MsgBox "İşlem Tamam", vbInformation
çıkış:
End Sub
 
hturkavci03' Alıntı:
Tekrar Merhaba,

Sayın çıtır, verdiğiniz kodları aşağıdaki gibi değiştirerek F sütunundaki verileri gözden uzak bir yere aldım ve istediğim gibi çalışıyor. Çok teşekkür ederim.
Genişletmek için tıkla ...
Sayın hturkavci03 sorununuzun çözüm bulduğuna sevindim.Dönüş yaptığınız için teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst