• DİKKAT

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

Makro İle Yan Sayfaya Koşullu Kopyalama

M

mustafa1205

Altın Üye
Katılım
23 Ekim 2010
Mesajlar
1,436
Excel Vers. ve Dili
Office 2016 / 64 Bit - Türkçe
Ekte bulunan örnekte de açıklama yapmaya çalıştım. Çalışmam da bulunan data sayfasındaki satırı yanında bulunan değere göre yan sayfaya kopyalamak istiyorum.Teşekkür ederim
 

Ekli dosyalar

Sayfadaki veriler sıfırlacan mı_?
Veri tabanı şeklinde mi olacak
Yoksa her seferinde Data sekmesinin dışındaki veriler silinip yeni veriler mi eklenecek.
 
Hocam yeni yazabiliyorum kusura bakmayın.Hayır sıfırlama yapmayacağım sadece data sayfasındaki F sütununda bulunan değerlere göre F sütunun solunda kalan hücreleri buton ile diğer sayfalara dolu satırın bir alt satırına kopyalama işlemi yapmak istiyorum
 
mustafa1207' Alıntı:
Hocam yeni yazabiliyorum kusura bakmayın.Hayır sıfırlama yapmayacağım sadece data sayfasındaki F sütununda bulunan değerlere göre F sütunun solunda kalan hücreleri buton ile diğer sayfalara dolu satırın bir alt satırına kopyalama işlemi yapmak istiyorum
Genişletmek için tıkla ...

Data sayfası veriler aktarıldıktan sonra temizlenecek mi_? Peki
Bunu sormamın sebebi şu devamlı kayıt yaparsanız aynı kayıtları alt alta yapar buda sanırım işinizi görmez
 
Hocam size zamanında cevap veremiyorum öncelikle özür dilerim işyerinde olmam nedeniyle bu şekilde oldu. Evet dediğiniz gibi silme işlemi yapmayacak sadece altalta kopyalasın istiyorum. Yani ben silme işlemini kendim manuel yapacağım.Teşekkür ederim
 
mustafa1207' Alıntı:
Hocam size zamanında cevap veremiyorum öncelikle özür dilerim işyerinde olmam nedeniyle bu şekilde oldu. Evet dediğiniz gibi silme işlemi yapmayacak sadece altalta kopyalasın istiyorum. Yani ben silme işlemini kendim manuel yapacağım.Teşekkür ederim
Genişletmek için tıkla ...

Merhaba
Kodu boş bir module kopyalayın ve deneyin
Kod: 
Option Explicit
Sub aktarımlar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
trabzonspor = MsgBox("Verileri Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Dim s1, s2, s3, s4, s5
Dim s2s, s3s, s4s, s5s
Set s1 = Sheets("DATA")
Set s2 = Sheets("Sayfa1")
Set s3 = Sheets("Sayfa2")
Set s4 = Sheets("Sayfa3")
Set s5 = Sheets("Sayfa4")
For ts = 2 To s1.Cells(Rows.Count, "B").End(xlUp).Row
If s1.Cells(ts, "F") = 1 Or s1.Cells(ts, "F") = "A" Then
s2s = s2.Range("B" & Rows.Count).End(xlUp).Row
s2.Range("B" & s2s + 1) = s1.Cells(ts, "B")
s2.Range("C" & s2s + 1) = s1.Cells(ts, "C")
s2.Range("D" & s2s + 1) = s1.Cells(ts, "D")
s2.Range("E" & s2s + 1) = s1.Cells(ts, "E")
ElseIf s1.Cells(ts, "F") = 2 Or s1.Cells(ts, "F") = "B" Then
s3s = s3.Range("B" & Rows.Count).End(xlUp).Row
s3.Range("B" & s3s + 1) = s1.Cells(ts, "B")
s3.Range("C" & s3s + 1) = s1.Cells(ts, "C")
s3.Range("D" & s3s + 1) = s1.Cells(ts, "D")
s3.Range("E" & s3s + 1) = s1.Cells(ts, "E")
ElseIf s1.Cells(ts, "F") = 3 Or s1.Cells(ts, "F") = "C" Then
s4s = s4.Range("B" & Rows.Count).End(xlUp).Row
s4.Range("B" & s4s + 1) = s1.Cells(ts, "B")
s4.Range("C" & s4s + 1) = s1.Cells(ts, "C")
s4.Range("D" & s4s + 1) = s1.Cells(ts, "D")
s4.Range("E" & s4s + 1) = s1.Cells(ts, "E")
ElseIf s1.Cells(ts, "F") = 4 Or s1.Cells(ts, "F") = "D" Then
s5s = s5.Range("B" & Rows.Count).End(xlUp).Row
s5.Range("B" & s5s + 1) = s1.Cells(ts, "B")
s5.Range("C" & s5s + 1) = s1.Cells(ts, "C")
s5.Range("D" & s5s + 1) = s1.Cells(ts, "D")
s5.Range("E" & s5s + 1) = s1.Cells(ts, "E")
ElseIf s1.Cells(ts, "F") = 5 Or s1.Cells(ts, "F") = "E" Then
s2s = s2.Range("B" & Rows.Count).End(xlUp).Row
s2.Range("B" & s2s + 1) = s1.Cells(ts, "B")
s2.Range("C" & s2s + 1) = s1.Cells(ts, "C")
s2.Range("D" & s2s + 1) = s1.Cells(ts, "D")
s2.Range("E" & s2s + 1) = s1.Cells(ts, "E")
s3s = s3.Range("B" & Rows.Count).End(xlUp).Row
s3.Range("B" & s3s + 1) = s1.Cells(ts, "B")
s3.Range("C" & s3s + 1) = s1.Cells(ts, "C")
s3.Range("D" & s3s + 1) = s1.Cells(ts, "D")
s3.Range("E" & s3s + 1) = s1.Cells(ts, "E")
s4s = s4.Range("B" & Rows.Count).End(xlUp).Row
s4.Range("B" & s4s + 1) = s1.Cells(ts, "B")
s4.Range("C" & s4s + 1) = s1.Cells(ts, "C")
s4.Range("D" & s4s + 1) = s1.Cells(ts, "D")
s4.Range("E" & s4s + 1) = s1.Cells(ts, "E")
s5s = s5.Range("B" & Rows.Count).End(xlUp).Row
s5.Range("B" & s5s + 1) = s1.Cells(ts, "B")
s5.Range("C" & s5s + 1) = s1.Cells(ts, "C")
s5.Range("D" & s5s + 1) = s1.Cells(ts, "D")
s5.Range("E" & s5s + 1) = s1.Cells(ts, "E")
End If
Next
For ts = 2 To Sheets.Count
Sheets(ts).Select
trabzonspor = Sheets(ts).Range("B" & Rows.Count).End(xlUp).Row
Sheets(ts).Range("A2") = 1
Sheets(ts).Range("A2:A" & trabzonspor).DataSeries rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, step:=1, Trend:=True
Next
Sheets("DATA").Select
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürde İşlem Tamamlandı", , "Bitiş"
End Sub
 
Hocam Elinize sağlık çok güzel olmuş.Tam istediğim gibi oldu.Tekrar teşekkürler.Hayırlı günler diliyorum
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst