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

sldrkyurdal · 12 Kasım 2018

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.

askm · 12 Kasım 2018

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

Orion1 · 12 Kasım 2018

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.

Dosyanız ektedir.

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

Mustafa MUTLU · 12 Kasım 2018

Ş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

sldrkyurdal · 12 Kasım 2018

Teşekkürler

Mustafa MUTLU · 12 Kasım 2018

sldrkyurdal' Alıntı:
Teşekkürler

Hayırlı geceler

sldrkyurdal · 12 Kasım 2018

Orion1' Alıntı:

Dosyanız ektedir.

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

teşekkürler .

sldrkyurdal · 12 Kasım 2018

Orion1' Alıntı:

Dosyanız ektedir.

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

Teşekkürler

Orion1 · 12 Kasım 2018

sldrkyurdal' Alıntı:
Teşekkürler

Rica ederim.
İyi çalışmalar.

Ziynettin · 12 Kasım 2018

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

gicimi · 13 Kasım 2018

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

Sn. @askm merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.

gicimi · 13 Kasım 2018

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

Sn. @Ziynettin Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.

gicimi · 13 Kasım 2018

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

Sn. @Mustafa MUTLU Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.

gicimi · 13 Kasım 2018

Orion1' Alıntı:

Dosyanız ektedir.

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

Sn. @Orion1 Merhaba;
Başlıklarında diğer sayfalara gelmesi için kodda nasıl bir güncelleme yapılmalı.

Ziynettin · 13 Kasım 2018

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

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 · 13 Kasım 2018

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

Zaten başlıklarda geliyor.

gicimi · 13 Kasım 2018

@Orion1 n Bey kodları farklı bir çalışma sayfasında deniyorum. Bilgileri aktarıyor ama 1. Satırları getirmiyor. (Başlık Bilgilerini)

Orion1 · 13 Kasım 2018

gicimi' Alıntı:
@Orion1 n Bey kodları farklı bir çalışma sayfasında deniyorum. Bilgileri aktarıyor ama 1. Satırları getirmiyor. (Başlık Bilgilerini)

Gelmesi lazım.Örnek dosyanızı yollayın bakayım.

gicimi · 13 Kasım 2018

Bu an mobilim akşam dosyayı ekleyebilirim.

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

sldrkyurdal

Ekli dosyalar

askm

Destek Ekibi

Orion1

Uzman

Ekli dosyalar

Mustafa MUTLU

Destek Ekibi

sldrkyurdal

Mustafa MUTLU

Destek Ekibi

sldrkyurdal

sldrkyurdal

Orion1

Uzman

Ziynettin

Destek Ekibi

gicimi

gicimi

gicimi

gicimi

Ziynettin

Destek Ekibi

Orion1

Uzman

gicimi

Orion1

Uzman

gicimi