Süz ve Aktar

[manly]

Gönderdiğim dosyada T sütunundaki verilere göre süzerek sonuçlarını aynı isme sahip olan sayfalara aktarılmasını istiyorum. Yardım ederseniz sevinirim.

 

[usubaykan]

Merhaba;

Aşağıdaki kodu dener misiniz?

Option Explicit

Sub Süz_aktar()
Dim U As Long, Son_Satır As Long
Application.ScreenUpdating = False
    For U = 2 To Sheets("DATABASE").[T65536].End(3).Row
        If Sheets("DATABASE").Cells(U, "T") <> "" Then
            Sheets("DATABASE").Rows(U).Copy
            Son_Satır = Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Range("A65536").End(3).Row + 1
            Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Rows(Son_Satır).PasteSpecial xlValues
        End If
    Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır", vbInformation
End Sub

 

[manly]

Bu kodu nereye yazmam gerekiyor. Butona tanımladım olmadı..

 

[usubaykan]

Merhaba;
Kullandığınız toogle button olduğu için bu şekilde kullanmalısınız.

[COLOR=Red]Private Sub CommandButton1_Click()[/COLOR]
Dim U As Long, Son_Satır As Long
Application.ScreenUpdating = False
    For U = 2 To Sheets("DATABASE").[T65536].End(3).Row
        If Sheets("DATABASE").Cells(U, "T") <> "" Then
            Sheets("DATABASE").Rows(U).Copy
            Son_Satır = Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Range("A65536").End(3).Row + 1
            Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Rows(Son_Satır).PasteSpecial xlValues
        End If
    Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır", vbInformation
End Sub

#2 nolu mesajım düğmeye eklerseniz çalışır.

 

[manly]

Çok teşekkür ederim şimdi oldu...

 

[usubaykan]

Rica ederim ;-)

Çok teşekkür ederim şimdi oldu...

 

[manly]

Bu kodun açıklamasını rica etsem açıklar mısınız?...

Private Sub CommandButton1_Click()
Dim U As Long, Son_Satır As Long
Application.ScreenUpdating = False
For U = 2 To Sheets("DATABASE").[T65536].End(3).Row
If Sheets("DATABASE").Cells(U, "T") <> "" Then
Sheets("DATABASE").Rows(U).Copy
Son_Satır = Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Range("A65536").End(3).Row + 1
Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Rows(Son_Satır).PasteSpecial xlValues
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır", vbInformation
End Sub

 

[usubaykan]

Merhaba;

Tabiki

Bu kodun açıklamasını rica etsem açıklar mısınız?...

Private Sub CommandButton1_Click() = 'Buton1'e basıldığında
Dim U As Long ' U = Uzun, Son_Satır As Long '=Uzun
Application.ScreenUpdating = False 'Ekrandaki hareketleri gösterme.
For U = 2 To Sheets("DATABASE").[T65536].End(3).Row 'U değişkeni 2 den başla database sayfasının t sütunundaki en son dolu olan hücreye kadar döngü oluştur.
If Sheets("DATABASE").Cells(U, "T") <> "" Then ' Eğer database sayfasının T sütununda ki U satırı eşit değişse boşa
Sheets("DATABASE").Rows(U).Copy ' database U satırını kopyala.
Son_Satır = Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Range("A65536").End(3).Row + 1 'Son_Satır T sütunundaki U satırlarına ait isimli sayfaların en son satıra eşit.
Sheets("" & Sheets("DATABASE").Cells(U, "T") & "").Rows(Son_Satır).PasteSpecial xlValues'T sütunundaki U satırlarına ait isimli sayfaların en son satıra değerlerini yapıştır.
End If 'Sonlandır
Next 'devam
Application.CutCopyMode = False ' Kopya modunu iptal et.
Application.ScreenUpdating = True ' 'Ekrandaki hareketleri göster
MsgBox "İşleminiz tamamlanmıştır", vbInformation'Mesaj kutusu"İşleminiz tamamlanmıştır", visualbasicBilgi
End Sub'The End

 

[manly]

Merhaba,

Öncelikle çok teşekkür ederim. Yeni olduğum için biraz karışık geliyor.

Ben bu dosyada "T" sütunundaki isimleri değiştirsem, ve sayfalara da bu sütundaki isimleri versem bu kod çalışır mı?

 

[usubaykan]

Merhaba;
Evet

Merhaba,

Öncelikle çok teşekkür ederim. Yeni olduğum için biraz karışık geliyor.

Ben bu dosyada "T" sütunundaki isimleri değiştirsem, ve sayfalara da bu sütundaki isimleri versem bu kod çalışır mı?

 

[manly]

Çok sağolun. Teşekkürler...

 

[manly]

Sayın usubaykan,

Sakıncası yoksa bir sorum daha olacak...

Sorum, "T" sütununda "g" adlı bir kelime var diyelim. Çalışma sayfa isimlerinde "g" isminde bir çalışma sayfam yok ve hata veriyor. Hatayı da "g" isminde çalışma sayfası olmadığından veriyor. Yalnız, hem böyle bir çalışma sayfası olmayacak, hem de "T" sütununda "g" gibi bir kelime olması gerekiyor. Ben sadece çalışma sayfa isimleriyle eşleşenleri süzüp gerekli yerlere aktarsın istiyorum. Böyle bir kod lazım...

Ayrıca "Aktarılanları Sil" butonuna tıkladığımda, aktarılan sayfalardaki verileri silebileceğim bir kod lazım..acaba bu mümkün mü?

 

[usubaykan]

Merhaba;

Private Sub CommandButton1_Click()
Dim U As Long, Son_Satır As Long
Application.ScreenUpdating = False
[COLOR=Red]On Error Resume Next[/COLOR]

Kırmızı renkli satırı eklerseniz hata versede next' e gideceğinden sayfanın olmaması bir problem teşkil etmez. Rahatlıkla "G" harfini kullanabilirisiniz.

Aktarılanları sil komutu tüm aktarılmış verileri mi silecek yoksa en son aktarılanları mı?
yani A sayfasında 2. satırından başlayıp W satırındaki en son dolu hücreye kadar mı silecek?

 

[manly]

Evet, tüm aktarılanları silecek...Her aktarma işleminde sayfalar boş olması gerekiyor.

 

[usubaykan]

Merhaba;

Private Sub CommandButton2_Click()
Dim Sayfalar As Worksheet
Application.ScreenUpdating = False
    For Each Sayfalar In Worksheets
    If Sayfalar.Name <> "DATABASE" Then
    Sayfalar.Range("A2:W" & Sayfalar.Range("W65536").End(3).Row + 1).ClearContents
    End If
    Next
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır", vbInformation
End Sub

Silmek için bu kodu kullanmanız yeterli.

Evet, tüm aktarılanları silecek...Her aktarma işleminde sayfalar boş olması gerekiyor.

 

[manly]

Çok teşekkür ederim. Allah razı olsun.

 

[usubaykan]

Çok teşekkür ederim. Allah razı olsun.

Rica ederim. ;-) Cümlemizden.