Sayfadaki bilgileri türe göre eşleme ???

[serkanatmis]

Değerli arkadaşlar
Elimde iki çalışma sayfasından 8 er sutunlu birinde 1500 diğerinde 2000 civarında kayıt olan bir dosya var. Ortak özellikleri ORDER denilen bir kod numarası. Yapmak istediğim bu iki sayfada bununan bilgileri tek bir sayfada yan yana yazdırmak.

Ekte küçük bir örnek koydum. Orada ki gibi bir tarafta olan order lerin karşısındaki iki tane ise altındaki satırı boş olarak görmek istiyoruz. Fakat satır sayısı çok fazla olduğundan bunu manuel yapamıyorum. Yardımlarınız ve önerileriniz için şimdiden teşekkürler...

 

[Ferhat Pazarçevirdi]

Aşağıdakileri, standart bir modül sayfasına kopyalayıp, çalıştırınız.

Option Base 1
Sub Esleme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shE As Worksheet
Dim sh As Worksheet
Dim arrLst()
Dim bul As Range
Dim i&, j&, x&, y&, bassat&, z&
Dim adres As String
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
Set shE = Sheets("eşleme")
ReDim Preserve arrLst(1)
shE.Rows("3:65536").Delete
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> shE.Name Then
        For i = 3 To sh.Cells(65536, 1).End(xlUp).Row
            For j = 1 To UBound(arrLst)
                If sh.Cells(i, 1) = arrLst(j) Then: x = x + 1
            Next j
            If x = 0 Then
                y = y + 1
                ReDim Preserve arrLst(y)
                arrLst(y) = sh.Cells(i, 1)
            Else
                x = 0
            End If
        Next i
    End If
Next
For i = 1 To UBound(arrLst)
    bassat = shE.UsedRange.Rows.Count + 1
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shE.Name Then
            z = z + 1
            Set bul = sh.Columns(1).Find(arrLst(i), lookat:=xlWhole)
            If Not bul Is Nothing Then
                adres = bul.Address
                x = bassat
                Do
                    If z Mod 2 <> 0 Then
                        shE.Cells(x, 1) = arrLst(i)
                        For j = 1 To 5
                            shE.Cells(x, j + 1) = sh.Cells(bul.Row, j + 1)
                        Next j
 
                    Else
 
                        shE.Cells(x, 7) = arrLst(i)
                        For j = 1 To 5
                            shE.Cells(x, j + 7) = sh.Cells(bul.Row, j + 1)
                        Next j
 
                    End If
 
                    Set bul = sh.Columns(1).FindNext(bul)
                    x = x + 1
                Loop While Not bul Is Nothing And bul.Address <> adres
                x = 0
            End If
        End If
    Next
    z = 0
Next i
Set bul = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Set shE = Nothing
End Sub