• DİKKAT

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

Aynı olan verileri başka sayfaya taşıma

S

sldrkyurdal

Katılım
18 Ağustos 2017
Mesajlar
119
Excel Vers. ve Dili
excel.2013
Merhaba,
Bir konuda desteğinize ihtiyaç duyuyorum.
Çalışma sayfamdaki bilgilerden "isim" satırına göre başka sayfalara dağıtmak istiyorum Örneğin isimleri Ali olanları tüm başlıklar ile alsın Ali olan sayfaya kopyalasın.
desteğinizi rica ederim örnek listemi ekledim.
Teşekkürler.
 

Ekli dosyalar

Kod: 
Sub askm()
Application.ScreenUpdating = False
Set s1 = Sheets("data")
Dim son As Long
son = s1.Range("C" & Rows.Count).End(3).Row
For i = 2 To son
    For Syf = 1 To Worksheets.Count
        If UCase(Worksheets(Syf).Name) = UCase(s1.Cells(i, 3).Value) Then
            son2 = Worksheets(Syf).Range("C" & Rows.Count).End(3).Row + 1
            s1.Range("A" & i & ":E" & i).Copy Worksheets(Syf).Cells(son2, 1)
            Exit For
        End If
    Next Syf
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub
 
sldrkyurdal' Alıntı:
Merhaba,
Bir konuda desteğinize ihtiyaç duyuyorum.
Çalışma sayfamdaki bilgilerden "isim" satırına göre başka sayfalara dağıtmak istiyorum Örneğin isimleri Ali olanları tüm başlıklar ile alsın Ali olan sayfaya kopyalasın.
desteğinizi rica ederim örnek listemi ekledim.
Teşekkürler.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Sub aktarsayfa59()
Dim sh As Worksheet, adet As String, i As Integer
Sheets("data").Select
Range("A1").AutoFilter
For i = 2 To Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:E").ClearContents
    Range("A1").AutoFilter field:=3, Criteria1:=sh.Name
    Range("A1").CurrentRegion.Copy sh.Range("A1")
    Range("A1").AutoFilter field:=3
Next i
Range("A1").AutoFilter
MsgBox "İşlem tamamdır."
End Sub
 

Ekli dosyalar

Şu kodu deneyin
Cevap almışınız ama alternatif olsun..

Sub AKTAR()
Dim s As Worksheet
Dim a As Long, b As Long, c As Long
Set s = Sheets("data")
For a = 2 To Sheets.Count
For b = 2 To s.Cells(65536, 2).End(3).Row
If s.Cells(b, "C") Like Sheets(a).Name Then
c = Sheets(a).Cells(65536, 1).End(3).Row + 1
Sheets(a).Cells(c, 1) = s.Cells(b, 1)
Sheets(a).Cells(c, 2) = s.Cells(b, 2)
Sheets(a).Cells(c, 3) = s.Cells(b, 3)
Sheets(a).Cells(c, 4) = s.Cells(b, 4)
Sheets(a).Cells(c, 5) = s.Cells(b, 5)
End If
Next b
Next a
MsgBox "Aktarımlar Yapılmıştır."
End Sub
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Sub aktarsayfa59()
Dim sh As Worksheet, adet As String, i As Integer
Sheets("data").Select
Range("A1").AutoFilter
For i = 2 To Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:E").ClearContents
    Range("A1").AutoFilter field:=3, Criteria1:=sh.Name
    Range("A1").CurrentRegion.Copy sh.Range("A1")
    Range("A1").AutoFilter field:=3
Next i
Range("A1").AutoFilter
MsgBox "İşlem tamamdır."
End Sub
Genişletmek için tıkla ...


teşekkürler .
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Sub aktarsayfa59()
Dim sh As Worksheet, adet As String, i As Integer
Sheets("data").Select
Range("A1").AutoFilter
For i = 2 To Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:E").ClearContents
    Range("A1").AutoFilter field:=3, Criteria1:=sh.Name
    Range("A1").CurrentRegion.Copy sh.Range("A1")
    Range("A1").AutoFilter field:=3
Next i
Range("A1").AutoFilter
MsgBox "İşlem tamamdır."
End Sub
Genişletmek için tıkla ...

Teşekkürler
 
Bende hazırlamıştım. Alternatif olsun.

Kod: 
Sub Sayfalara_dagit()
Set s2 = Sheets("data")
a = s2.Range("A2:E" & s2.Cells(Rows.Count, 1).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        d(a(i, 3)) = ""
    Next i

ReDim b(1 To UBound(a), 1 To 5)
    If d.Count > 0 Then
        For Each syf In d.keys
            Set s1 = Sheets(syf)
            For i = 1 To UBound(a)
                krt = a(i, 3)
                If UCase(a(i, 3)) = UCase(s1.Name) Then
                    say = say + 1
                    For j = 1 To 5
                        b(say, j) = a(i, j)
                    Next j
                End If
            Next i
            s1.[A2].Resize(say, 5) = b
            say = 0
        Next syf
    End If
MsgBox "İşlem tamam.", vbInformation
End Sub
 
askm' Alıntı:
Kod: 
Sub askm()
Application.ScreenUpdating = False
Set s1 = Sheets("data")
Dim son As Long
son = s1.Range("C" & Rows.Count).End(3).Row
For i = 2 To son
    For Syf = 1 To Worksheets.Count
        If UCase(Worksheets(Syf).Name) = UCase(s1.Cells(i, 3).Value) Then
            son2 = Worksheets(Syf).Range("C" & Rows.Count).End(3).Row + 1
            s1.Range("A" & i & ":E" & i).Copy Worksheets(Syf).Cells(son2, 1)
            Exit For
        End If
    Next Syf
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub
Genişletmek için tıkla ...

Sn. @askm merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.
 
Ziynettin' Alıntı:
Bende hazırlamıştım. Alternatif olsun.

Kod: 
Sub Sayfalara_dagit()
Set s2 = Sheets("data")
a = s2.Range("A2:E" & s2.Cells(Rows.Count, 1).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        d(a(i, 3)) = ""
    Next i

ReDim b(1 To UBound(a), 1 To 5)
    If d.Count > 0 Then
        For Each syf In d.keys
            Set s1 = Sheets(syf)
            For i = 1 To UBound(a)
                krt = a(i, 3)
                If UCase(a(i, 3)) = UCase(s1.Name) Then
                    say = say + 1
                    For j = 1 To 5
                        b(say, j) = a(i, j)
                    Next j
                End If
            Next i
            s1.[A2].Resize(say, 5) = b
            say = 0
        Next syf
    End If
MsgBox "İşlem tamam.", vbInformation
End Sub
Genişletmek için tıkla ...

Sn. @Ziynettin Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.
 
Mustafa MUTLU' Alıntı:
Şu kodu deneyin
Cevap almışınız ama alternatif olsun..

Sub AKTAR()
Dim s As Worksheet
Dim a As Long, b As Long, c As Long
Set s = Sheets("data")
For a = 2 To Sheets.Count
For b = 2 To s.Cells(65536, 2).End(3).Row
If s.Cells(b, "C") Like Sheets(a).Name Then
c = Sheets(a).Cells(65536, 1).End(3).Row + 1
Sheets(a).Cells(c, 1) = s.Cells(b, 1)
Sheets(a).Cells(c, 2) = s.Cells(b, 2)
Sheets(a).Cells(c, 3) = s.Cells(b, 3)
Sheets(a).Cells(c, 4) = s.Cells(b, 4)
Sheets(a).Cells(c, 5) = s.Cells(b, 5)
End If
Next b
Next a
MsgBox "Aktarımlar Yapılmıştır."
End Sub
Genişletmek için tıkla ...

Sn. @Mustafa MUTLU Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Sub aktarsayfa59()
Dim sh As Worksheet, adet As String, i As Integer
Sheets("data").Select
Range("A1").AutoFilter
For i = 2 To Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:E").ClearContents
    Range("A1").AutoFilter field:=3, Criteria1:=sh.Name
    Range("A1").CurrentRegion.Copy sh.Range("A1")
    Range("A1").AutoFilter field:=3
Next i
Range("A1").AutoFilter
MsgBox "İşlem tamamdır."
End Sub
Genişletmek için tıkla ...

Sn. @Orion1 Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.
 
gicimi' Alıntı:
Sn. @Ziynettin Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.
Genişletmek için tıkla ...

Kod: 
Sub sayfalara_aktar()
Set s2 = Sheets("data")
a = s2.Range("A1:E" & s2.Cells(Rows.Count, 1).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")

    For i = 2 To UBound(a)
        d(a(i, 3)) = ""
    Next i

ReDim b(1 To UBound(a), 1 To 5)
    If d.Count > 0 Then
        For Each syf In d.keys
            Set s1 = Sheets(syf)
            For i = 2 To UBound(a)
                krt = a(i, 3)
                If UCase(a(i, 3)) = UCase(s1.Name) Then
                    say = say + 1
                    For j = 1 To 5
                        b(say, j) = a(i, j)
                    Next j
                End If
            Next i
            s1.[A1].Resize(, 5) = Array(a(1, 1), a(1, 2), a(1, 3), a(1, 4), a(1, 5))
            s1.[A2].Resize(say, 5) = b
            say = 0
        Next syf
    End If
MsgBox "İşlem tamam.", vbInformation
End Sub
 
@Orion1 n Bey kodları farklı bir çalışma sayfasında deniyorum. Bilgileri aktarıyor ama 1. Satırları getirmiyor. (Başlık Bilgilerini)
 
Bu an mobilim akşam dosyayı ekleyebilirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst