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

vturkmen

Altın Üye
Katılım
19 Haziran 2005
Mesajlar
13
Excel Vers. ve Dili
OFFİCE 365 MSO (16.0.12527.20880) 64 BİT
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.
 

Ekli dosyalar

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,181
Excel Vers. ve Dili
Ofis 365 Türkçe
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

Altın Üye
Katılım
19 Haziran 2005
Mesajlar
13
Excel Vers. ve Dili
OFFİCE 365 MSO (16.0.12527.20880) 64 BİT
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ı.
 

Ekli dosyalar

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,181
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

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

Kod:
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
 
Son düzenleme:

vturkmen

Altın Üye
Katılım
19 Haziran 2005
Mesajlar
13
Excel Vers. ve Dili
OFFİCE 365 MSO (16.0.12527.20880) 64 BİT
Teşekkür ederim. Deneyeceğim inşallah.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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

Altın Üye
Katılım
19 Haziran 2005
Mesajlar
13
Excel Vers. ve Dili
OFFİCE 365 MSO (16.0.12527.20880) 64 BİT
Kod:
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

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,181
Excel Vers. ve Dili
Ofis 365 Türkçe
Benim kodlar nasıl çalıştı acaba merak ettim.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,181
Excel Vers. ve Dili
Ofis 365 Türkçe
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?
 
Üst