Aynı kodu içeren satırları, yan yana ayrı ayrı hücrelere tek satıra yazdırmak

[pedasabyem]

Merhaba,

Esas alınacak benzersiz kodlar A sütununda. A sütununda aynı olan kodların satırlarındaki bilgiler, tek satıra yan yana gelmeli.
Zaten B, C, D, E, F aynı bilgileri içeriyor. Birer kere yazılarak yan yana gelecek.
Fakat A'da aynı kodlar olduğu halde, G, H ve I sütunlarındaki bilgiler birbirlerinden faklı. (3RG-40668 kodu için örnek; G2, G3 ve G4 / örnek;H2, H3 ve H4 / örnek; I2, I3, I4).
VB kodunu çalıştırdıktan sonra işlenmiş bilgi "Sayfa2"ye yazmalı.

Ek'teki excel dosyasını ve excel dosyasının .jpg olarak görünümünü bilginize sunuyorum.
Yardımcı olabilecek arkadaşları şimdiden teşekkürlerimi sunarım.
Saygılarımla

 

[dEdE]

Merhaba,
Dosyanız ektedir.
Kodlar, verilerinizin A sütununa göre sıralı olduğu (örnek dosyanızda olduğu gibi) varsayılarak yazılmıştır. Eğer sıralı değilse ya manuel olarak sıralamalısınız ya da koda sıralama eklenmelidir.
Sütun sayısı kullandığınız excel versiyonunun desteklediği sutun sayısını geçerse hata oluşacaktır.
Hoşçakalın.

Sub Aktar()
Dim Dizi() As Long

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Son = s1.Range("A" & Rows.Count).End(3).Row
ReDim Dizi(Son)
Satır = 2: x = 0: n = 0

For i = 2 To Son
    If s1.Cells(i, 1).Value = s1.Cells(i + 1, 1).Value Then
        x = x + 1
     Else
        Dizi(n) = x + 1
        n = n + 1
        x = 0
    End If
Next

wmax = WorksheetFunction.Max(Dizi)
s2.Cells.ClearContents
s2.Range("A1:F1").Value = s1.Range("A1:F1").Value
s2.Cells(1, 7).Resize(, wmax) = s1.Cells(1, 7)
s2.Cells(1, 7 + wmax).Resize(, wmax) = s1.Cells(1, 8)
s2.Cells(1, 7 + wmax + wmax).Resize(, wmax) = s1.Cells(1, 9)

For i = 1 To n
    ss = s2.Range("A" & Rows.Count).End(3).Row + 1
    s2.Range("A" & ss & ":F" & ss).Value = s1.Range("A" & Satır & ":F" & Satır).Value
    For q = 7 To 9
        For j = Satır To Dizi(i - 1) + Satır - 1
            sk = s2.Rows(ss).Find("*", , , , xlByColumns, xlPrevious).Column + 1
            If sk < 7 Then sk = 7
            If q = 8 And sk < 7 + wmax Then sk = 7 + wmax
            If q = 9 And sk < 7 + wmax + wmax Then sk = 7 + wmax + wmax
            s2.Cells(ss, sk).Value = s1.Cells(j, q).Value
        Next
    Next
    Satır = Satır + Dizi(i - 1)
Next i
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[pedasabyem]

Çok teşekkür ederim üstad, ellerinize bilginize sağlık.
1 gündür dosyalara uygulamaya çalışıyorum. Umarım istediğim gibi olacak.

 

[pedasabyem]

Bir çok dosyamda (Excel 2010 kullanıyorum) kodu çalıştırdıktan sonra aşağıdaki hatayı veriyor.

visual basic runtime error '13'
Type mismatch

Debug'a tıkladığımda ise; wmax = WorksheetFunction.Max(Dizi)
satırını işaret ediyor.

Sanırım sizin dediğiniz gibi sütun sayısı ile ilgili olabilir.
Henüz düzeltemedim ama uğraşıyorum halen

 

[dEdE]

Merhaba,
Aşağıdaki kodu kırmızı ile işaretlediğim satırın altına ekleyerek dener misiniz?

[COLOR="Red"]wmax = WorksheetFunction.Max(Dizi)[/COLOR]
If wmax > 16378 Then
MsgBox "Sütun sayısı işlemi gerçekleştirmek için yeterli değil" & Chr(10) & _
"İşlem sonlandırılacak", vbCritical, "D İ K K A T"
Exit Sub
End If

 

[pedasabyem]

Teşekkür ederim elinize bilginize sağlık.