aynı öğrencilere ait farklı 3 sayfadaki bilgileri tek listede birleştirme

[vturkmen]

ekte verdiğim örnek liste exel dosyası 3 sayfadan oluşuyor.
Listeleri tek bir liste haline nasıl getirebiliriz.
öğrenci numaraları sabit olsun

Yardımcı olursanız seviniriz. Teşekkürler.

 

[Necdet]

Merhaba,

Birleştirilen sayfada başlık sıralaması nasıl olacak?

Arkadaşlar kodları yazacak, sonra bu sıralama şöyle olsun, böyle olsun diye yeni isteklerde bulunacaksınız.
Haksız mıyım?

 

[vturkmen]

Merhaba,

Birleştirilen sayfada başlık sıralaması nasıl olacak?

Arkadaşlar kodları yazacak, sonra bu sıralama şöyle olsun, böyle olsun diye yeni isteklerde bulunacaksınız.
Haksız mıyım?

Öncelikle ilginize teşekkür ederim.
4.sayfa başlık sıralaması.

 

[Necdet]

Merhaba,

Biraz düşünmeden yazdım ama işe yarıyor galiba, aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Birleştir()

    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        Kol As Integer, _
        c   As Range, _
        Sh4 As Worksheet, _
        Sh  As Worksheet
    
    Set Sh4 = Sheets("Sayfa4")
    Sh4.Select
    Sh4.Range("A1").CurrentRegion.Offset(1).Clear
    
    Sheets("Sayfa1").Range("A2:D" & Sheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row).Copy Sh4.Range("A2")
    
    Kol = 3
    
    For k = 2 To 3
        Set Sh = Sheets(k)
        Kol = Kol + 2
        For i = 2 To Sh.Cells(Rows.Count, "A").End(3).Row
            Set c = Sh4.Range("A:A").Find(Sh.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                If k = 2 Then
                    Sheets(k).Range("C" & i & ":D" & i).Copy Sh4.Cells(c.Row, Kol)
                Else
                    Sheets(k).Range("D" & i & ":E" & i).Copy Sh4.Cells(c.Row, Kol)
                End If
            End If
            
        Next i
    Next k
    
End Sub

 

[vturkmen]

Teşekkür ederim. Deneyeceğim inşallah.

 

[veyselemre]

Sub TEST()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set s3 = Sheets("Sayfa3")
    Set s4 = Sheets("Sayfa4")
    son1 = s1.Cells(Rows.Count, 1).End(3).Row
    v1 = s1.Range("A2:D" & son1).Value
    son2 = s2.Cells(Rows.Count, 1).End(3).Row
    v2 = s2.Range("A2:D" & son2).Value
    son3 = s3.Cells(Rows.Count, 1).End(3).Row
    v3 = s3.Range("A2:E" & son3).Value
    mx = son1
    If son2 > mx Then mx = son2
    If son3 > mx Then mx = son3
    ReDim liste(1 To mx - 1, 1 To 8)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v1)
            ogrNo = Trim(v1(i, 1) & v1(i, 2))
            If Not .exists(ogrNo) Then
                say = say + 1
                liste(say, 1) = v1(i, 1)
                liste(say, 2) = v1(i, 2)
                liste(say, 3) = v1(i, 3)
                liste(say, 4) = v1(i, 4)
                .Item(ogrNo) = say
            End If
        Next i
        For i = 1 To UBound(v2)
            ogrNo = Trim(v2(i, 1) & v2(i, 2))
            If .exists(ogrNo) Then
                say = .Item(ogrNo)
                liste(say, 5) = v2(i, 3)
                liste(say, 6) = v2(i, 4)
            Else
                MsgBox ogrNo & " Nolu Öğrenci Bulunamadı."
            End If
        Next i
        For i = 1 To UBound(v3)
            ogrNo = Trim(v3(i, 1) & v3(i, 2))
            If .exists(ogrNo) Then
                say = .Item(ogrNo)
                liste(say, 7) = v3(i, 4)
                liste(say, 8) = v3(i, 5)
            Else
                MsgBox ogrNo & " Nolu Öğrenci Bulunamadı."
            End If
        Next i
    End With
    s4.Range("A2:H" & Rows.Count).ClearContents
    s4.Range("A2:H" & mx).Value = liste

End Sub

 

[vturkmen]

Sub TEST()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set s3 = Sheets("Sayfa3")
    Set s4 = Sheets("Sayfa4")
    son1 = s1.Cells(Rows.Count, 1).End(3).Row
    v1 = s1.Range("A2:D" & son1).Value
    son2 = s2.Cells(Rows.Count, 1).End(3).Row
    v2 = s2.Range("A2:D" & son2).Value
    son3 = s3.Cells(Rows.Count, 1).End(3).Row
    v3 = s3.Range("A2:E" & son3).Value
    mx = son1
    If son2 > mx Then mx = son2
    If son3 > mx Then mx = son3
    ReDim liste(1 To mx - 1, 1 To 8)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v1)
            ogrNo = Trim(v1(i, 1) & v1(i, 2))
            If Not .exists(ogrNo) Then
                say = say + 1
                liste(say, 1) = v1(i, 1)
                liste(say, 2) = v1(i, 2)
                liste(say, 3) = v1(i, 3)
                liste(say, 4) = v1(i, 4)
                .Item(ogrNo) = say
            End If
        Next i
        For i = 1 To UBound(v2)
            ogrNo = Trim(v2(i, 1) & v2(i, 2))
            If .exists(ogrNo) Then
                say = .Item(ogrNo)
                liste(say, 5) = v2(i, 3)
                liste(say, 6) = v2(i, 4)
            Else
                MsgBox ogrNo & " Nolu Öğrenci Bulunamadı."
            End If
        Next i
        For i = 1 To UBound(v3)
            ogrNo = Trim(v3(i, 1) & v3(i, 2))
            If .exists(ogrNo) Then
                say = .Item(ogrNo)
                liste(say, 7) = v3(i, 4)
                liste(say, 8) = v3(i, 5)
            Else
                MsgBox ogrNo & " Nolu Öğrenci Bulunamadı."
            End If
        Next i
    End With
    s4.Range("A2:H" & Rows.Count).ClearContents
    s4.Range("A2:H" & mx).Value = liste

End Sub

Veysel Bey teşekkür ederim hatasız çalıştı.

 

[Necdet]

Benim kodlar nasıl çalıştı acaba merak ettim.

 

[Tevfik_Kursun]

Merhaba Necdet Hocam,
İlk resim sizin çalışma, ikincisi Veysel Emre'nin
Saygılarımla

 

[Necdet]

Merhaba,
Kodları değiştirdim fakat sonuç farklı. Çünkü iki Öğrenci numarası eşleşiyor.
Kurduğum mantıkta Öğrenci Numaralarının çift olmaması gerekiyordu.

Mantık ta bunu gerektirmiyor mu?

 

[Tevfik_Kursun]

Sayın Necdet Hocam,

Mantık ta bunu gerektirmiyor mu?

evet haklısınız.
Saygılarımla