İki ayrı sayfadaki listeleri satır satır birleştirme

[vedat1905]

sorum şu 8. sınıf sayfasında 8. sınıf liste ve 7. sınıf sayfasında 7. sınıf liste var bu iki listeyi sayfa 8den 1. satır sayfa7den ikinci satır olacak şekilde aşağıya doğru sıralanmasını istiyorum.

 

[vedat1905]

Sub karma_liste_oluştur()
Application.ScreenUpdating = False
Set s3 = ThisWorkbook.Worksheets("BİRLES")
Set s1 = ThisWorkbook.Worksheets("KIZ").Range("A1").CurrentRegion
Set S2 = ThisWorkbook.Worksheets("ERKEK").Range("A1").CurrentRegion
sut = S2.Columns.Count
sa = 4
s1.Copy s3.Range("A1")
For i = 2 To S2.Rows.Count
If i Mod 2 = 1 Then
S2.Range(S2.Cells(i - 1, 1), S2.Cells(i, sut)).Copy
s3.Range("A" & sa).Insert Shift:=xlDown
sa = sa + 4
ElseIf i = S2.Rows.Count And i Mod 2 = 0 Then
S2.Range(S2.Cells(i, 1), S2.Cells(i, sut)).Copy
s3.Range("A" & sa).Insert Shift:=xlDown
sa = sa + 4
End If
Next
End Sub


BU KOD İKİ SAYFADAKİ LİSTEYİ İKİŞER İKİŞER ALIYOR BENİM İSTEDİĞİM BİR BİR ALSIN

 

[pitchoute]

Merhaba, yedek aldıktan sonra deneyip sonucu paylaşabilir misiniz?

Sub karma_liste_olustur_birer_birer()
    Application.ScreenUpdating = False
    
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    
    Set s1 = ThisWorkbook.Worksheets("KIZ")
    Set s2 = ThisWorkbook.Worksheets("ERKEK")
    Set s3 = ThisWorkbook.Worksheets("BİRLES")
    
    Dim kizRange As Range
    Dim erkekRange As Range
    
    Set kizRange = s1.Range("A1").CurrentRegion
    Set erkekRange = s2.Range("A1").CurrentRegion
    
    Dim sutunSayisi As Integer
    sutunSayisi = WorksheetFunction.Max(kizRange.Columns.Count, erkekRange.Columns.Count)
    
    s3.Cells.Clear
    
    Dim satirSayisi As Integer
    satirSayisi = WorksheetFunction.Max(kizRange.Rows.Count, erkekRange.Rows.Count)
    
    Dim hedefSatir As Integer
    hedefSatir = 1
    
    kizRange.Rows(1).Copy s3.Range("A1")
    hedefSatir = hedefSatir + 1
    
    For i = 2 To satirSayisi
        If i <= kizRange.Rows.Count Then
            kizRange.Rows(i).Copy s3.Rows(hedefSatir)
            hedefSatir = hedefSatir + 1
        End If
        
        If i <= erkekRange.Rows.Count Then
            erkekRange.Rows(i).Copy s3.Rows(hedefSatir)
            hedefSatir = hedefSatir + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Karma liste oluşturuldu.", vbInformation
End Sub

 

[vedat1905]

Teşekkür ederim.

 

[pitchoute]

Rica ederim iyi çalışmalar