Seçime Göre Farklı Sayfalara veri aktarma

[DeliBalta58]

Ekteki dosyamda Veri sayfasında İsim Listem Mevcut.

E Sütununda verilen Ünvanlara göre sıra ile ;

Unvan_1 olanlar Sayfa1 e ,
Unvan_2 olanlar Sayfa2 ye
Unvan_3 olanlar Sayfa3 e
.................................

verilerin aktarılması gerekmektedir.

Yardımlarınız için şimdiden teşekkürler.

 

[asi_kral]

Ekteki dosyamda Veri sayfasında İsim Listem Mevcut.

E Sütununda verilen Ünvanlara göre sıra ile ;

Unvan_1 olanlar Sayfa1 e ,
Unvan_2 olanlar Sayfa2 ye
Unvan_3 olanlar Sayfa3 e
.................................

verilerin aktarılması gerekmektedir.

Yardımlarınız için şimdiden teşekkürler.

Merhaba
Kitabınızın kod bölümünde bulunan Thisworkbook bölümüne bu kodu kopyalayın ve deneyin.

Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If ActiveSheet.Name = "veri" Then Exit Sub
Dim s1 As Worksheet, s2 As Worksheet
Dim asi As Long, kral As String, yıldız As Variant
Set s1 = Sheets("veri"): Set s2 = ActiveSheet
Application.ScreenUpdating = False
yıldız = ActiveCell.Address
s2.Range("A2:E" & Rows.Count).ClearContents
asi = s1.Range("B" & Rows.Count).End(xlUp).Row
kral = Replace(s2.Name, "Sayfa", "Unvan_")
s1.Range("A1:E" & asi).AutoFilter field:=5, Criteria1:=kral
If WorksheetFunction.Subtotal(3, s1.Range("B2:B" & asi)) > 0 Then
s1.Range("B2:E" & asi).Copy
s2.Range("B2").PasteSpecial (xlPasteValues)
End If
s1.Range("A1:E" & asi).AutoFilter
s2.Range("A2") = 1
s2.Range("A2:B" & s2.Range("B" & Rows.Count).End(xlUp).Row).DataSeries _
rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, step:=1, Trend:=False
Range(yıldız).Select
Application.ScreenUpdating = True
MsgBox kral & " Verilerini Aktardım" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte.

 

[uzmanamele]

Merhaba

Bunun gibi bir kod işinizi görür mü?

Sub SayfalaraAktar()
Application.ScreenUpdating = False
    Sheets(Array("Sayfa1", "Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5", "Sayfa6", "Sayfa7", _
        "Sayfa8", "Sayfa9")).Select
    Sheets("Sayfa1").Activate
    Rows("2:65536").Select
    Selection.ClearContents
Set s1 = Sheets("veri")
For i = 2 To s1.Range("a65536").End(3).Row
SayfaNo = Right(s1.Cells(i, "e"), 1)
SayfaAdi = "Sayfa" & SayfaNo
s1.Range("B" & i & ":" & "E" & i).Copy
Sheets(SayfaAdi).Select
ssat = Range("b65536").End(3).Row
Range("b" & ssat + 1).Select
ActiveSheet.Paste
Next

    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    s1.Select
End Sub

 

[DeliBalta58]

Her ikinizin de Ellerinize sağlık hocam.
Hemde Nasıl görür.