• DİKKAT

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

Farklı Sayfalardaki Verilerden Tek Liste Yap

B

baydeniro

Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Merhaba Arkadaşlar,
Farklı sayfalardaki verilerden her kodu 1 kere kullanarak tek liste yapılması mümkün müdür ? Örnek dosyayı ekledim.
 

Ekli dosyalar

Deneyiniz..
Kod: 
Sub Test()
    Dim i, Sayf, SonSat1, SonSat2
    Application.ScreenUpdating = False
    Range("A2:B10000").ClearContents
    For i = 1 To Sheets.Count
        Set Sayf = Sheets(i)
        If Sayf.Name <> "TABLO" Then
            SonSat1 = Cells(Rows.Count, 1).End(3).Row + 1
            SonSat2 = Sayf.Cells(Rows.Count, 1).End(3).Row
            Range(Cells(SonSat1, 1), Cells((SonSat1 + SonSat2) - 2, 2)).Value = Sayf.Range(Sayf.Cells(2, 1), Sayf.Cells(SonSat2, 2)).Value
        End If
    Next
    Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=2
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam..."
End Sub
 
EmrExcel16' Alıntı:
Deneyiniz..
Kod: 
Sub Test()
    Dim i, Sayf, SonSat1, SonSat2
    Application.ScreenUpdating = False
    Range("A2:B10000").ClearContents
    For i = 1 To Sheets.Count
        Set Sayf = Sheets(i)
        If Sayf.Name <> "TABLO" Then
            SonSat1 = Cells(Rows.Count, 1).End(3).Row + 1
            SonSat2 = Sayf.Cells(Rows.Count, 1).End(3).Row
            Range(Cells(SonSat1, 1), Cells((SonSat1 + SonSat2) - 2, 2)).Value = Sayf.Range(Sayf.Cells(2, 1), Sayf.Cells(SonSat2, 2)).Value
        End If
    Next
    Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=2
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam..."
End Sub
Genişletmek için tıkla ...
Harikasınız üstad. Harika çalışıyor. Sağlıcakla kalın.
 
Aynı zamanda sıralansın istersen. Application.ScreenUpdating = True şu satırın hemen üstüne aşağıdaki kod satırını ekleyebilirsiniz.

Kod: 
 Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Sort Key1:=[A2], Order1:=xlAscending
 
EmrExcel16' Alıntı:
Aynı zamanda sıralansın istersen. Application.ScreenUpdating = True şu satırın hemen üstüne aşağıdaki kod satırını ekleyebilirsiniz.

Kod: 
 Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Sort Key1:=[A2], Order1:=xlAscending
Genişletmek için tıkla ...
Çok teşekkür ederim üstadım böyle daha da harika oldu.
 
Alternatif;

Dictionary yöntemi ile benzersiz liste oluşturuluyor. Yoğun veride hız olarak avantaj sağlayabilir.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "TABLO" Then
            Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sayfa.Range("A2:B" & Son).Value2
                For X = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(X, 2)) Then
                        Dizi.Add Veri(X, 2), Veri(X, 1)
                    End If
                Next
            End If
        End If
    Next
   
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif;

Dictionary yöntemi ile benzersiz liste oluşturuluyor. Yoğun veride hız olarak avantaj sağlayabilir.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Zaman As Double
  
    Zaman = Timer
  
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "TABLO" Then
            Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sayfa.Range("A2:B" & Son).Value2
                For X = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(X, 2)) Then
                        Dizi.Add Veri(X, 2), Veri(X, 1)
                    End If
                Next
            End If
        End If
    Next
  
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Üstad çok teşekker ederim. Harika bir alternatif oldu. Sağlıcakla kalın.
 
Korhan Ayhan' Alıntı:
Alternatif;

Dictionary yöntemi ile benzersiz liste oluşturuluyor. Yoğun veride hız olarak avantaj sağlayabilir.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Zaman As Double
  
    Zaman = Timer
  
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "TABLO" Then
            Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sayfa.Range("A2:B" & Son).Value2
                For X = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(X, 2)) Then
                        Dizi.Add Veri(X, 2), Veri(X, 1)
                    End If
                Next
            End If
        End If
    Next
  
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Üstad kod bu haliyle çok iyi. Teknik olarak mümkün müdür bilemiyorum. Acaba tüm sayfaları değil de "TABLO" sayfasının sağında kalan veya A (1) ile A (7) sayfaları arasında kalan gibi bir sınırlama yapılabilir mi ?
 
Veri alınacak sayfa sayısı maksimum kaç oluyor?
 
EmrExcel16' Alıntı:
Deneyiniz..
Kod: 
Sub Test()
    Dim i, Sayf, SonSat1, SonSat2
    Application.ScreenUpdating = False
    Range("A2:B10000").ClearContents
    For i = 1 To Sheets.Count
        Set Sayf = Sheets(i)
        If Sayf.Name <> "TABLO" Then
            SonSat1 = Cells(Rows.Count, 1).End(3).Row + 1
            SonSat2 = Sayf.Cells(Rows.Count, 1).End(3).Row
            Range(Cells(SonSat1, 1), Cells((SonSat1 + SonSat2) - 2, 2)).Value = Sayf.Range(Sayf.Cells(2, 1), Sayf.Cells(SonSat2, 2)).Value
        End If
    Next
    Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=2
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam..."
End Sub
Genişletmek için tıkla ...
Üstad selamlar, verileri A-B sütunları yerine D-E sütunlarına yerleştirmek için kodu revize etmeye çalıştım ama nereleri değiştirmem gerektiğini bulamadım. Acaba D-E konusunda yardımcı olmanız mümkün mü rica etsem.
 
Tablo sayfası mı verilerin alındığı sayfalar mı yoksa her ikisi içinde geçerli olacak mı ? Yani A-B iptal mi oldu.
 
teşekkürler üstad. Kaynak Veriler aynı A-B, yerleşim yeri olarak D-E.
 
Bu şekilde deneyiniz..
Kod: 
Sub Test()
    Dim i, Sayf, SonSat1, SonSat2
    Application.ScreenUpdating = False
    Range("D2:E10000").ClearContents
    For i = 1 To Sheets.Count
        Set Sayf = Sheets(i)
        If Sayf.Name <> "TABLO" Then
            SonSat1 = Cells(Rows.Count, 4).End(3).Row + 1
            SonSat2 = Sayf.Cells(Rows.Count, 1).End(3).Row
            Range(Cells(SonSat1, 4), Cells((SonSat1 + SonSat2) - 2, 5)).Value = _
            Sayf.Range(Sayf.Cells(2, 1), Sayf.Cells(SonSat2, 2)).Value
        End If
    Next
    Range("D2:E" & Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=2
    Range("D2:E" & Cells(Rows.Count, 4).End(3).Row).Sort Key1:=[D2], Order1:=xlAscending
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam..."
End Sub
 
EmrExcel16' Alıntı:
Bu şekilde deneyiniz..
Kod: 
Sub Test()
    Dim i, Sayf, SonSat1, SonSat2
    Application.ScreenUpdating = False
    Range("D2:E10000").ClearContents
    For i = 1 To Sheets.Count
        Set Sayf = Sheets(i)
        If Sayf.Name <> "TABLO" Then
            SonSat1 = Cells(Rows.Count, 4).End(3).Row + 1
            SonSat2 = Sayf.Cells(Rows.Count, 1).End(3).Row
            Range(Cells(SonSat1, 4), Cells((SonSat1 + SonSat2) - 2, 5)).Value = _
            Sayf.Range(Sayf.Cells(2, 1), Sayf.Cells(SonSat2, 2)).Value
        End If
    Next
    Range("D2:E" & Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=2
    Range("D2:E" & Cells(Rows.Count, 4).End(3).Row).Sort Key1:=[D2], Order1:=xlAscending
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam..."
End Sub
Genişletmek için tıkla ...
Üstad çok çok teşekkür ediyorum. Sağlıcakla kalın.
 
Sayfa isimlerini belirterek işlemleri yapabilirsiniz.

"Sayfa" isimli değişkene istediğiniz kadar isim ekleyerek işlemi yapabilirsiniz. Bu yöntem sayfa sayısının az olduğu durumlarda tercih edilebilir.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Variant, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Byte, Y As Long, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
    Sayfa = Array("A(1)", "A(2)", "A(3)", "A(4)", "A(5)", "A(6)", "A(7)")
   
    For X = 0 To UBound(Sayfa)
        If Sayfa(X) <> "TABLO" Then
            Son = Sheets(Sayfa(X)).Cells(Sheets(Sayfa(X)).Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sheets(Sayfa(X)).Range("A2:B" & Son).Value2
                For Y = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(Y, 2)) Then
                        Dizi.Add Veri(Y, 2), Veri(Y, 1)
                    End If
                Next
            End If
        End If
    Next
   
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Ya da sayfa index numaralarını kullanarak işlemi yapabilirsiniz.

Bu yöntemde sayfa adı belirtilmediği için çok sayfalı dosyalarda tercih edilebilir. TABLO isimli sayfanın sağında kalan tüm sayfalar işleme alınır.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Variant, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Byte, Y As Long, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    For X = Sheets("TABLO").Index + 1 To Sheets(Sheets.Count).Index
        Set Sayfa = Sheets(X)
        If Sayfa.Name <> "TABLO" Then
            Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sayfa.Range("A2:B" & Son).Value2
                For Y = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(Y, 2)) Then
                        Dizi.Add Veri(Y, 2), Veri(Y, 1)
                    End If
                Next
            End If
        End If
    Next
   
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Ayhan' Alıntı:
Sayfa isimlerini belirterek işlemleri yapabilirsiniz.

"Sayfa" isimli değişkene istediğiniz kadar isim ekleyerek işlemi yapabilirsiniz. Bu yöntem sayfa sayısının az olduğu durumlarda tercih edilebilir.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Variant, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Byte, Y As Long, Zaman As Double
  
    Zaman = Timer
  
    Set Dizi = CreateObject("Scripting.Dictionary")
    Sayfa = Array("A(1)", "A(2)", "A(3)", "A(4)", "A(5)", "A(6)", "A(7)")
  
    For X = 0 To UBound(Sayfa)
        If Sayfa(X) <> "TABLO" Then
            Son = Sheets(Sayfa(X)).Cells(Sheets(Sayfa(X)).Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sheets(Sayfa(X)).Range("A2:B" & Son).Value2
                For Y = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(Y, 2)) Then
                        Dizi.Add Veri(Y, 2), Veri(Y, 1)
                    End If
                Next
            End If
        End If
    Next
  
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Ya da sayfa index numaralarını kullanarak işlemi yapabilirsiniz.

Bu yöntemde sayfa adı belirtilmediği için çok sayfalı dosyalarda tercih edilebilir. TABLO isimli sayfanın sağında kalan tüm sayfalar işleme alınır.

C++: 
Option Explicit

Sub Sayfalardan_Benzersiz_Liste_Olustur()
    Dim Sayfa As Variant, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Byte, Y As Long, Zaman As Double
  
    Zaman = Timer
  
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    For X = Sheets("TABLO").Index + 1 To Sheets(Sheets.Count).Index
        Set Sayfa = Sheets(X)
        If Sayfa.Name <> "TABLO" Then
            Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Veri = Sayfa.Range("A2:B" & Son).Value2
                For Y = LBound(Veri, 1) To UBound(Veri, 1)
                    If Not Dizi.Exists(Veri(Y, 2)) Then
                        Dizi.Add Veri(Y, 2), Veri(Y, 1)
                    End If
                Next
            End If
        End If
    Next
  
    With Sheets("TABLO")
        .Range("A2:B" & .Rows.Count).Clear
        .Range("A2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Items, Dizi.Keys))
        .Range("A2:B" & .Rows.Count).Sort Key1:=.Range("A2"), Order1:=xlAscending
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Üstad çok teşekkür ediyorum. Çok harika alternatiflerimiz olsun sayenizde. Sağlıcakla kalın.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst