Birçok Sayfadan Veri Getirmek!!!!

[sinan05]

iyi Günler, herkese hayırlı yıllar dilerim. Aşağıya ekledğim kodlarla çalışma kitabımdaki "VERİLER" sayfasından "ANA SAYFA" ya verileri kopyalıyorum. Fakat kitabıma onlarca sayfa ekledim ve sürekli sayfalar artıyor. İstediğim çalışma kitabımdaki tüm sayfalardaki verileri "ANA SAYFA" sayfasına verilerin sadece değerlerini kopyalamak. Eklediğim makro buna uyarlanırmı bilemiyorum.Yardımlarınız için teşekkür ederim.
Sub KAYİT2()
Application.ScreenUpdating = False
Dim S1 As Worksheet, S2 As Worksheet, Defterler(), Son As Long, Satır As Long
Set S1 = Sheets("VERİLER")
Defterler = Array("ANA SAYFA")
Satır = 4
For Each defter In Defterler
Set S2 = Sheets(defter)
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
Son1 = Sheets("ANA SAYFA").[a65536].End(3).Row + 1
For x = 4 To Son
S2.Range("A" & x & ":U" & x).Copy
Sheets("ANA SAYFA").Cells(Son1, 1).PasteSpecial xlPasteValues
Son1 = Son1 + 1
Next x
Next
Range("B4").Select
S2.Range("A4:U" & S2.Rows.Count).ClearContents
Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Merhaba.
Örnek dosya hazırlayın. Sayfalardan veriler Ana sayfaya alındığında nasıl olmasını istiyorsanız uygulayarak gösterin.
Örnek dosyanızı dosya.tc gibi bir siteye ekleyebilirsiniz.

 

[sinan05]

Merhaba.
Örnek dosya hazırlayın. Sayfalardan veriler Ana sayfaya alındığında nasıl olmasını istiyorsanız uygulayarak gösterin.
Örnek dosyanızı dosya.tc gibi bir siteye ekleyebilirsiniz.

Merhaba Muzaffer hocam. Örnek dosyayı ekledim linki : https://s6.dosya.tc/server6/c5pn9n/ornek_dosya.xlsm.html

Hocam burdaki amacım diğer sayfalardaki 2. satırda bulunan a2:ı2: arası verileri ana sayfa ya yalnızca değerleri şeklinde kopyalamak.

 

[Muzaffer Ali]

Hiç örnek yapmamışsınız.
En azından bir tane örnek yapın.

Örneğin "Veriler" sayfasına gerçeğe yakın değerler yazın.
Veriler sayfasından "Ana Sayfa" ya elinizle verileri aktarın.

Ben de bu örneğe göre kod yazayım.

 

[sinan05]

hocam her sayfanın 2 satırı dolu benim istediğim alan burası zaten. ana sayfa daki listele butonu veriler sayfasının 2.satırdaki a ile ı aralığını getiriyor. benim istediğim ilaveten tüm sayfalardaki aynı aralığın verilerinide getirsin. başka girilmesi gereken veri yok ki. listele butonu veriler sayfasındakini getiriyor bütün sayfalarınkini getirmesi lazım.

Hiç örnek yapmamışsınız.
En azından bir tane örnek yapın.

Örneğin "Veriler" sayfasına gerçeğe yakın değerler yazın.
Veriler sayfasından "Ana Sayfa" ya elinizle verileri aktarın.

Ben de bu örneğe göre kod yazayım.

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub Test()
    Application.ScreenUpdating = False
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long, Saysyf As Long
    Set syfAna = Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" Then
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            Saysyf = syf.Cells(Rows.Count, "A").End(xlUp).Row
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[sinan05]

Aşağıdaki kodu deneyin.

Sub Test()
    Application.ScreenUpdating = False
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long, Saysyf As Long
    Set syfAna = Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" Then
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            Saysyf = syf.Cells(Rows.Count, "A").End(xlUp).Row
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Hocam elinize sağlık çok teşekkür ederim tam istediğim gibi oldu harika.
2 isteğimi rica edebilirmiyim.1.si Hocam kopyalamasını istemediğim" bitenler " sayfası var bu sayfayı kopylamasa
2. bu sayfalar çağaldıkça ağırlaşıyor bende bitenleri arşivliyorum. makro kaydederek veya kodları değiştirerek uğraştım araştırdım yapamadım.eğer her sayfanın h6 hücresinde "bitti" yazıyorsa o sayfayı masaüstünde bulunan yedekler klosöründeki data kitabına kopyalasa sonrada o sayfayı benim kitabımdan silse çok güzel olur. bunlarıda yaparsak işlerimi yapabilcem çok makbule geçe MUZAFFER Hocamr.

 

[Muzaffer Ali]

Data dosyası kapalıysa açıp sayfa taşıyıp kaydedip kapatır. Data dosyası açıksa sadece sayfayı taşır.

Option Explicit

Sub Test()
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long
    Application.ScreenUpdating = False
    Set syfAna = ThisWorkbook.Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" And Not syf.Name = "Bitenler" Then 'Başka kopyalanmasını istemediğiniz sayfa varsa bu satırdaki gibi ekleyebilirsiniz.
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
        If syf.Range("H6") = "Bitti" Then SayfaTasi syf
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı."
End Sub

Sub SayfaTasi(syf As Worksheet)
    Dim wb As Workbook, wbData As Workbook
    Dim DataDosyaAdi As String
    Dim DataDosyaYolu As String
    
    DataDosyaAdi = "Data.xlsx"
    DataDosyaYolu = Environ("UserProfile") & "\Desktop\Yedekler\"
    
    For Each wb In Workbooks
        If wb.Name = DataDosyaAdi Then
            Set wbData = wb
            Exit For
        End If
    Next
    If wbData Is Nothing Then
        Workbooks.Open DataDosyaYolu & DataDosyaAdi
        syf.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        ActiveWorkbook.Close True
    Else
        syf.Move After:=wbData.Sheets(wbData.Sheets.Count)
        ThisWorkbook.Activate
    End If
End Sub

 

[sinan05]

Data dosyası kapalıysa açıp sayfa taşıyıp kaydedip kapatır. Data dosyası açıksa sadece sayfayı taşır.

Option Explicit

Sub Test()
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long
    Application.ScreenUpdating = False
    Set syfAna = ThisWorkbook.Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" And Not syf.Name = "Bitenler" Then 'Başka kopyalanmasını istemediğiniz sayfa varsa bu satırdaki gibi ekleyebilirsiniz.
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
        If syf.Range("H6") = "Bitti" Then SayfaTasi syf
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı."
End Sub

Sub SayfaTasi(syf As Worksheet)
    Dim wb As Workbook, wbData As Workbook
    Dim DataDosyaAdi As String
    Dim DataDosyaYolu As String
  
    DataDosyaAdi = "Data.xlsx"
    DataDosyaYolu = Environ("UserProfile") & "\Desktop\Yedekler\"
  
    For Each wb In Workbooks
        If wb.Name = DataDosyaAdi Then
            Set wbData = wb
            Exit For
        End If
    Next
    If wbData Is Nothing Then
        Workbooks.Open DataDosyaYolu & DataDosyaAdi
        syf.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        ActiveWorkbook.Close True
    Else
        syf.Move After:=wbData.Sheets(wbData.Sheets.Count)
        ThisWorkbook.Activate
    End If
End Sub

Muzaffer Hocam eksik olmayın çok güzel hazırlamışsınız çok sağolun. Fakat ben anlatamadım sanırım, bu "If syf.Range("H6") = "Bitti" Then SayfaTasi syf" kodu SayfaTası makrosu için istiyordum. Yani sayfaların H6 hücresinde BİTTİ yazıyorsa o sayfa taşınsın diye düşünmüştüm. sayfalardan ana sayfaya veri getirirken herhangi bir koşula gerek yok Hocam.
NOT: Muzaffer Hocam herhalde ben olayı yanlış anladım. Üsteki makro koşula göre SayfaTaşı makrosunu çalıştırıyor galiba.

 

[sinan05]

Muzaffer Hocam SayfaTaşı makrosunda bu kod "Workbooks.Open DataDosyaYolu & DataDosyaAdi" hata veriyor. dosya masa üstünde dosya adlarınıda kontrol ettim bir hata yok.
NOT: MUZAFFER Hocam çalışma Data dosyasının uzantısı farklıymış xlsm olarak değiştirdim çalıştı.Aynen süper çalışıyor ALLAH RAZI OLSUN vakit ayırdınız çok teşekkür ederim emeğinize.

 

[Muzaffer Ali]

Allah hepimizden razı olsun inşallah.