• DİKKAT

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

Aynı Sayfadaki Farklı Verileri Farklı Sayfalara Göndermek

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.Aynı sayfadaki bazı verileri farklı sayfalara göndermek istiyorum.Teşekkür ediyorum
 

Ekli dosyalar

mustafa1207' Alıntı:
Ekte bulunan örnekte de açıklama yapmaya çalıştım.Aynı sayfadaki bazı verileri farklı sayfalara göndermek istiyorum.Teşekkür ediyorum
Genişletmek için tıkla ...

kod
Kod: 
Sub aktar()
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name <> "DATA" Then
Worksheets(Sheets(i).Name).Range("B2:D10").ClearContents
End If
Next
For r = 2 To Worksheets("DATA").Cells(Rows.Count, "B").End(3).Row
aranan1 = Sheets("DATA").Cells(r, "d").Value
If aranan1 = "EVLİ" Then
sayfa = "EVLİLER"
ElseIf aranan1 = "BEKAR" Then
sayfa = "BEKARLAR"
ElseIf aranan1 = "NİŞANLI" Then
sayfa = "NİŞANLILAR"
End If
sat = Worksheets(sayfa).Cells(Rows.Count, "B").End(3).Row + 1
Sheets(sayfa).Cells(sat, 2).Value = Sheets("DATA").Cells(r, 2).Value
Sheets(sayfa).Cells(sat, 3).Value = Sheets("DATA").Cells(r, 3).Value
Sheets(sayfa).Cells(sat, 4).Value = Sheets("DATA").Cells(r, 4).Value
Next r
MsgBox "işlem tamam"
End Sub
 
mustafa1207' Alıntı:
Ekte bulunan örnekte de açıklama yapmaya çalıştım.Aynı sayfadaki bazı verileri farklı sayfalara göndermek istiyorum.Teşekkür ediyorum
Genişletmek için tıkla ...

Merhaba
Boş bir module kopyalayın ve deneyin
Kod: 
Option Explicit
Sub sayfalara_aktar()
Dim ts, kaplan, trabzonspor, bordo
trabzonspor = MsgBox("Verileri Sayfalara Dağıtıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
For bordo = 2 To Sheets.Count
kaplan = 2
Sheets(bordo).Range("A2:D65536").ClearContents
For ts = 2 To Sheets("DATA").Cells(65536, "B").End(xlUp).Row
If Sheets("DATA").Cells(ts, "D") = Mid(Sheets(bordo).Name, 1, _
Len(Sheets(bordo).Name) - 3) Then
Sheets(bordo).Cells(kaplan, "B") = Sheets("DATA").Cells(ts, "B")
Sheets(bordo).Cells(kaplan, "C") = Sheets("DATA").Cells(ts, "C")
Sheets(bordo).Cells(kaplan, "D") = Sheets("DATA").Cells(ts, "D")
Sheets(bordo).Range("A2") = 1
Sheets(bordo).Range("A2:A" & kaplan).DataSeries rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, step:=1, Trend:=True
kaplan = kaplan + 1
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "Verileri Sayfalara Dağıttım", vbInformation, "Bitiş"
End Sub
 
Sevgili İhsan Hocam ve Halit Hocam geç teşekkürlerimi yazabildiğim için kusura bakmayın ancak yazabildim. Tam istediğim gibi olmuş ancak iki sorum daha olacak örneği de ekledim. İlki kod da kodun çalışma öncesi sayfaların temizlenmesinde benim çalışmamda 20 kadar sekme var ben sadece bu sayfaların ismini "Worksheets(Sheets(i).Name).Range("B2:D20").ClearContents
" kod bölümüne nasıl yazarım.Diğeride çalışmamda süzme işlemi yapıyorum. Bu süzme işlemi sonucun da verileri gönderme işlemini nasıl yapabiliriz. Teşekkürler
 

Ekli dosyalar

mustafa1207' Alıntı:
Sevgili İhsan Hocam ve Halit Hocam geç teşekkürlerimi yazabildiğim için kusura bakmayın ancak yazabildim. Tam istediğim gibi olmuş ancak iki sorum daha olacak örneği de ekledim. İlki kod da kodun çalışma öncesi sayfaların temizlenmesinde benim çalışmamda 20 kadar sekme var ben sadece bu sayfaların ismini "Worksheets(Sheets(i).Name).Range("B2:D20").ClearContents
" kod bölümüne nasıl yazarım.Diğeride çalışmamda süzme işlemi yapıyorum. Bu süzme işlemi sonucun da verileri gönderme işlemini nasıl yapabiliriz. Teşekkürler
Genişletmek için tıkla ...

Burada iki adet kod var birisi önceki işlemleri yapıyor diğeri E sutunundaki herhangibir hücreyi tıkla sonra aktar düğmesine tıkla istenen tarihleri süzerek aktarıyor.

Kod: 
Sub aktar()
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name = "EVLİLER" Or Sheets(i).Name = "BEKARLAR" Or Sheets(i).Name = "NİŞANLILAR" Then
Worksheets(Sheets(i).Name).Range("B2:E20").ClearContents
End If
Next
For r = 2 To Worksheets("DATA").Cells(Rows.Count, "B").End(3).Row
yer = ActiveWindow.Selection.Row
If Sheets("DATA").Cells(yer, 5).Value = Sheets("DATA").Cells(r, 5).Value Then
aranan1 = Sheets("DATA").Cells(r, 4).Value
If aranan1 = "EVLİ" Then
sayfa = "EVLİLER"
ElseIf aranan1 = "BEKAR" Then
sayfa = "BEKARLAR"
ElseIf aranan1 = "NİŞANLI" Then
sayfa = "NİŞANLILAR"
End If
sat = Worksheets(sayfa).Cells(Rows.Count, "B").End(3).Row + 1
Sheets(sayfa).Cells(sat, 2).Value = Sheets("DATA").Cells(r, 2).Value
Sheets(sayfa).Cells(sat, 3).Value = Sheets("DATA").Cells(r, 3).Value
Sheets(sayfa).Cells(sat, 4).Value = Sheets("DATA").Cells(r, 4).Value
Sheets(sayfa).Cells(sat, 5).Value = Sheets("DATA").Cells(r, 5).Value
End If
Next r
MsgBox "işlem tamam"
End Sub
Sub aktar2()
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name = "EVLİLER" Or Sheets(i).Name = "BEKARLAR" Or Sheets(i).Name = "NİŞANLILAR" Then
Worksheets(Sheets(i).Name).Range("B2:E20").ClearContents
End If
Next
For r = 2 To Worksheets("DATA").Cells(Rows.Count, "B").End(3).Row
aranan1 = Sheets("DATA").Cells(r, 4).Value
If aranan1 = "EVLİ" Then
sayfa = "EVLİLER"
ElseIf aranan1 = "BEKAR" Then
sayfa = "BEKARLAR"
ElseIf aranan1 = "NİŞANLI" Then
sayfa = "NİŞANLILAR"
End If
sat = Worksheets(sayfa).Cells(Rows.Count, "B").End(3).Row + 1
Sheets(sayfa).Cells(sat, 2).Value = Sheets("DATA").Cells(r, 2).Value
Sheets(sayfa).Cells(sat, 3).Value = Sheets("DATA").Cells(r, 3).Value
Sheets(sayfa).Cells(sat, 4).Value = Sheets("DATA").Cells(r, 4).Value
Sheets(sayfa).Cells(sat, 5).Value = Sheets("DATA").Cells(r, 5).Value
Next r
MsgBox "işlem tamam"
End Sub
 
Hocam ellerinize sağlık çok teşekkür ediyorum. Hayırlı akşamlar diliyorum
 
Merhaba
aynı konuda sıkıntı yaşadığım için farklı konu açmak yerine bu konu altında yardım istemeyi uygun gördüm.2.mesajda halit beyin verdiği kodu kendi çalışmama aktaramadım.Yardımcı olursanız sevinirim. ekte bulunan örnek çalışmada 1.sayfada bütünlemeye kalan öğrencilerin isimlerinin 3.sayfaya aktarılmasını istiyorum.Teşekkür ediyorum.
 

Ekli dosyalar

adem01' Alıntı:
Merhaba
aynı konuda sıkıntı yaşadığım için farklı konu açmak yerine bu konu altında yardım istemeyi uygun gördüm.2.mesajda halit beyin verdiği kodu kendi çalışmama aktaramadım.Yardımcı olursanız sevinirim. ekte bulunan örnek çalışmada 1.sayfada bütünlemeye kalan öğrencilerin isimlerinin 3.sayfaya aktarılmasını istiyorum.Teşekkür ediyorum.
Genişletmek için tıkla ...

Merhaba
Kodu boş bir module kopyalayın ve deneyin
Kod: 
Option Explicit
Sub aktar_61()
Dim ts, kaplan, trabzonspor
trabzonspor = MsgBox("Bütünlemeye Kalanları Aktarıyorum", _
vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
Sheets("bütünleme").Range("A2:B1048576").ClearContents
kaplan = 2
For ts = 2 To Sheets("özet").Cells(1048576, "A").End(xlUp).Row
If Sheets("özet").Cells(ts, "B") = "bütünleme" Then
Sheets("bütünleme").Cells(kaplan, "A") = Sheets("özet"). _
Cells(ts, "A")
Sheets("bütünleme").Cells(kaplan, "B") = Sheets("özet"). _
Cells(ts, "C")
kaplan = kaplan + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Bütünleme Aktarımı Tamamlandı", vbInformation, "Bitiş"
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst